You're welcome VA. I'm glad to have been able to assist.
Cheerio,
vcoolio.
You're welcome VA. I'm glad to have been able to assist.
Cheerio,
vcoolio.
Hello VA,
I've just realised that in the code above I've mistakenly set the sh variable to Sheet1. It should be 37.
Cheerio,
vcoolio.
Hello VA,
Are you looking at copy/pasting rows 1-13 from sheet37 (assume this is the sheet code) to all the other sheets starting at A1? If so, try the code amended as follows:-
Sub TestCopy()
Dim ws As Worksheet, sh As Worksheet
Set sh = Sheet1
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> "Sheet37" Then
sh.Rows("1:13").Copy ws.[A1]
End If
Next ws
Application.ScreenUpdating = True
End Sub
Display More
You'll need to change Sheet37 to the actual name of your source sheet.
I hope that this helps.
Cheerio,
vcoolio.
Hello Mo,
You had best upload a sample of your workbook and also give us a precise description of what you intend to do.
Cheerio,
vcoolio.
Hello Fullhouse,
You're welcome and I'm glad to have been able to assist.
I'm really happy that you spent the time foraging through information and working this out basically on your own. I laud you for that.
If you're interested, below is a condensed version of your code (but excluding the date part that you added in):-
Option Explicit
Sub Format_Data2()
Dim i As Long, lr As Long, ar As Variant
Dim ws As Worksheet: Set ws = Sheet1
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("E1:E" & lr).AdvancedFilter 2, , ws.[M1], 1 'Unique values moved temporarily to Column M.
ar = ws.Range("M2", ws.Range("M" & ws.Rows.Count).End(xlUp))
Application.ScreenUpdating = False
For i = 1 To UBound(ar)
With ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp))
.AutoFilter 1, ar(i, 1)
With .Offset(1)
If ar(i, 1) = "abc.com" Then
.Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany1"
.Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment1"
End If
If ar(i, 1) = "bcd.com" Then
.Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany2"
.Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment2"
End If
If ar(i, 1) = "edc.com" Then
.Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany3"
.Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment3"
End If
If ar(i, 1) = "blah.com" Then
.Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany2"
.Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment2"
End If
If ar(i, 1) = "bbb.com" Then
.Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany3"
.Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment3"
End If
If ar(i, 1) = "aa.com" Then
.Offset(, -1).Resize(.Rows.Count - 1) = "fakecompany2"
.Offset(, -2).Resize(.Rows.Count - 1) = "fakesegment2"
End If
.AutoFilter
End With
End With
Next i
ws.Columns.AutoFit
ws.Columns("M").Clear
Application.ScreenUpdating = True
End Sub
Display More
If you're willing to do a bit more research, what I've done in the above code is extract all the unique values in Column E using the AdvancedFilter and temporarily placing them in Column M. These unique values are then placed into an array(ar) which is then looped through and filtered for each unique value. This prevents many, many iterations which in turn speeds up the code and, as you stated earlier, you have around 100K rows of data so the saved iterations would be in the thousands. I tested this code on 150K rows and it took about three seconds to execute on my machine.
Column M is cleared at the end of code execution.
As you can see in the code, I've used 'IF' statements to identify the unique values for processing once filtered. You may want to research 'case statements in VBA' if you have the time. 'Case statements' can be used in place of 'IF' statements and may actually work more quickly.
Anyway, once again "well done" and good luck with your project.
I've attached your sample workbook with the above code implemented just so you can see how it works. There are about 230 rows of data in the sample.
Cheerio,
vcoolio.
Hello Fullhouse,
QuoteMy understanding is that if abc.com is in the column E and i want fake company in the column D, then the column offset is -1, but I am not sure what do i put on for row?
For each instance of abc.com, the offset for the same row but the previous column(D) is written as:
.Offset(, -1)
However, based on your last post, it appears that the sample you supplied is not exactly what you are working with so the best option is for you to upload a sample of your workbook which is an exact replica of your actual working workbook. If your data is sensitive then please use dummy data. We'll only need a dozen or so rows of data to test with. Please also include the code that you are presently working with. This will make it much easier for us to resolve this for you and will spare us guessing at what is supposed to actually be happening.
Cheerio,
vcoolio.
Hello Fullhouse,
You're welcome. I'm glad to have been able to assist.
Smart choice going with the Autofilter.
Does the Autofilter code in my first post do the task for you?
Cheerio,
vcoolio.
Hello Fullhouse,
You don't need the "AND" operator, so modifying your loop type code as follows may help:-
Sub populateBnC()
Dim i As Long
Dim lr As Long: lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To lr
If Sheet1.Cells(i, 1).Value = "abc.com" Then
Sheet1.Cells(i, 2).Value = "fakecompany1"
Sheet1.Cells(i, 3).Value = "fakesegment1"
Else
Sheet1.Cells(i, 2).Value = "n/a"
Sheet1.Cells(i, 3).Value = "n/a"
End If
Next i
Application.ScreenUpdating = True
End Sub
Display More
You'll note that the last row has been defined so the code will loop each cell in Column A to the last row (the rows are defined by the variable 'i'), find the value 'abc.com' and add the text to Columns B and C. Based on the sample that you have supplied, Sheets("Sheet2") has the sheet code 'Sheet1' which I have used above.
In this line of your code:-
I'm not sure if Worksheets("Sheet1") is a typo on your part.
A loop type code will work fairly quickly on a relatively small data set but if your data set is large, or could grow to be very large, using the AutoFilter will be a far better option. For example:-
Sub Test()
Application.ScreenUpdating = False
With Sheet1.Range("A1", Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp))
.AutoFilter 1, "abc.com"
.Offset(1, 1).Resize(.Rows.Count - 1) = "Fakecompany1"
.Offset(1, 2).Resize(.Rows.Count - 1) = "Fakesegment1"
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Display More
I hope that this helps.
Cheerio,
vcoolio.
You're welcome Intranet. I'm glad to have been able to assist and thanks for the feed back.
BTW, I just noticed a little typo in the code and I'm surprised that you didn't receive and error message.
This line:-
Dim ws1 As Worksheet
should be
Dim ws As Worksheet
Cheerio,
vcoolio.
Hello Alexiz,
Should you want to stay with your current method, a worksheet_change event code should do the task for you:-
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(9)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub
Application.ScreenUpdating = False
If Target.Value = "Close" Then
Target.Offset(, 1) = Date
Target.EntireRow.Copy Sheets("Closed Quotes").Range("A" & Rows.Count).End(3)(2)
ElseIf Target.Value = "Open" Then
Target.Offset(, 1) = Date
Range(Cells(Target.Row, "E"), Cells(Target.Row, "J")).Copy Sheets("Open Jobs").Range("C" & Rows.Count).End(3)(2)
End If
Application.ScreenUpdating = True
End Sub
Display More
With this code, each time you make an "Open" or "Close" selection from the drop downs, the data will be immediately transferred to its relevant sheet.
To implement this code:-
- Right click on the "Quotes" sheet tab.
- Select "View Code" from the menu that appears.
- In the big white code field that then appears, paste the above code.
You'll need to first delete all existing codes that you have.
I've attached your sample with the code implemented and all other codes removed. Test it to see if it's what you were hoping to achieve.
I hope that this helps.
Cheerio,
vcoolio.
Hello Intranet,
Based on the information that you have supplied, the following VBA code may help:-
Sub Test()
Application.ScreenUpdating = False
Dim cArr As Variant, pArr As Variant, i As Long
Dim wsD As Worksheet
Dim ws1 As Worksheet
Set ws = Worksheets("Data")
Set wsD = Worksheets(ws.[J1].Value)
nrow = wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1
cArr = Array("B3", "D3", "B5", "D5", "F5")
pArr = Array("A", "B", "C", "D", "E")
For i = LBound(cArr) To UBound(cArr)
ws.Range(cArr(i)).Copy
wsD.Range(pArr(i) & nrow).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Display More
Place the code into a standard module and assign it to a button.
I've attached your sample workbook with the code implemented. Just click on the "TEST ME" button to see how it works. Play with the data to see how it is transferred to the relevant 'name' sheet.
I hope that this helps.
Cheerio,
vcoolio.
You're welcome JH. I'm glad to have been able to assist.
I gather that you worked out how to change the destination target from A14 to A6 (opening post/post #5).
Good luck with your project.
Cheerio,
vcoolio.
Hello JH,
Another option:-
Option Explicit
Sub Uniques()
Dim c As Range, ar As Variant, var As Variant
Dim Rng As Range: Set Rng = Sheet2.Range("Q2", Sheet2.Range("Q" & Sheet2.Rows.Count).End(xlUp))
With Rng
With CreateObject("Scripting.Dictionary")
For Each c In Rng
var = .Item(c.Value)
Next c
ar = .Keys
End With
End With
Sheet1.Range("A14").Resize(UBound(ar) + 1) = Application.Transpose(ar)
End Sub
Display More
I hope that this helps.
Cheerio,
vcoolio.
Hello Funfex,
See if this at least heads you in the right direction:-
Sub Test()
Dim stgF As String, stgP As String
Dim lr As Long, nr As Long, i As Long
Dim wb As Workbook
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Worksheets("Sheet3")
Dim sh As Worksheet, cAr As Variant, pAr As Variant
stgP = "C:\Users\YOUR FILE PATH HERE"
stgF = Dir(stgP & "\*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Worksheets
sh.UsedRange.Offset(1).Clear
Next sh
Do While stgF <> vbNullString
Set wb = Workbooks.Open(stgP & "\" & stgF)
cAr = Array(wb.Sheets("Sheet1"), wb.Sheets("Sheet2"), wb.Sheets("Sheet3"))
pAr = Array(ws1, ws2, ws3)
For i = 0 To UBound(cAr)
cAr(i).UsedRange.Offset(1).Copy pAr(i).Range("B" & Rows.Count).End(3)(2)
lr = pAr(i).Cells(Rows.Count, "N").End(xlUp).Row
nr = pAr(i).Cells(Rows.Count, "A").End(xlUp).Row + 1
pAr(i).Range("A" & nr & ":A" & lr) = wb.Name
Next i
wb.Close Save = False
stgF = Dir()
Loop
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Display More
You'll need to place your file path in the variable stgP.
I hope that this helps.
Cheerio,
vcoolio.
Hello JLW-E,
You're welcome. I'm glad to have been able to assist.
Cheerio,
vcoolio.
Hello JLW-E,
See if the following code does the trick for you (untested):-
Option Explicit
Sub Test()
Dim sh As Worksheet, wsD As Worksheet, i As Long, nrow As Long
Dim ClArr As Variant, pArr As Variant
Set sh = Sheets("cvent21")
Set wsD = Sheets("2021")
ClArr = Array(4, 21, 22, 23, 3, 24, 14, 19, 9)
pArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "L")
nrow = wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1
Application.ScreenUpdating = False
With sh.[A1].CurrentRegion
.AutoFilter 26, "Y"
With .Offset(1)
For i = LBound(ClArr) To UBound(ClArr)
.Columns(ClArr(i)).Copy wsD.Range(pArr(i) & nrow)
Next i
End With
.AutoFilter
wsD.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Display More
I've added a simple criteria column(Z) to determine if an entry is a new registrant. Place a "Y" in a cell and the code will do the rest.
I hope that this helps.
Cheerio,
vcoolio.
Hello MAID1812,
Here's another VBA option:-
Option Explicit
Sub Test()
Dim sh As Worksheet, wsR As Worksheet, i As Long, nrow As Long
Dim ClArr As Variant, pArr As Variant, Crit1 As String, Crit2 As String
Set sh = Sheets("Data")
Set wsR = Sheets("Report")
wsR.[A3].CurrentRegion.Offset(1).Clear
Crit1 = Sheet1.[B3].Value
Crit2 = Sheet1.[B5].Value
ClArr = Array(1, 2, 3, 4, 5, 8)
pArr = Array("A", "F", "B", "C", "D", "E")
nrow = wsR.Cells(Rows.Count, 1).End(xlUp).Row + 1
Application.ScreenUpdating = False
With sh.[A1].CurrentRegion
.AutoFilter 4, Crit1
.AutoFilter 5, Crit2
With .Offset(1)
For i = LBound(ClArr) To UBound(ClArr)
.Columns(ClArr(i)).Copy wsR.Range(pArr(i) & nrow)
Next i
End With
.AutoFilter
wsR.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Display More
I hope that this helps.
Cheerio,
vcoolio.
Hello DezB,
I'm assuming that you have been using Gijsmo's code as the code I supplied doesn't include a message box.
So I'll hand you back to Gijsmo.
Cheerio,
vcoolio.