I have this code to find the values that belong to the value in cell C3 (and further down):
aantalrijen = .Range("A2", .Range("A2").End(xlDown)).Cells.Count
For I = 2 To aantalrijen + 1
For J = 108 To 112
For Each cell In .Range(.Cells(2, J), .Cells(aantalrijen, J)).Cells
cell.Value = Application.VLookup(.Cells(I, 3), Sheets("omzet").Range("C:DH"), J - 2, 0)
Next cell
Next J
Next I
I am aware this cannot be the most efficient way to get the desired result. How should I adjust the code to make it the most efficient?
Update:
For now I am satisfied with this result:
aantalrijen = .Range("A2", .Range("A2").End(xlDown)).Cells.Count
For J = 108 To 112
For I = 2 To aantalrijen
.Cells(I, J).Value = Application.VLookup(.Cells(I, 3), Sheets("omzet").Range("C:DH"), J - 2, 0)
Next I
Next J
End With
it is fast enough for me now and it returns the desired results.
Here:
Option Explicit
Sub Test()
Dim arrSource, arrData, i As Long, j As Long, ColI As Long, ColF As Long
Dim DictMatches As New Scripting.Dictionary
Dim DictHeaders As New Scripting.Dictionary
With ThisWorkbook
arrSource = .Sheets("omzet").UsedRange.Value
arrData = .Sheets("SheetName").UsedRange.Value 'change this for the worksheet you are working on
End With
For i = 1 To UBound(arrSource, 2) 'this will store the headers position
DictHeaders.Add arrSource(1, i) 'this will throw an error if you have any duplicate headers
Next i
For i = 2 To UBound(arrSource) 'this will store the row position for each match
DictMatches.Add arrSource(i, 3), i 'this will throw an error if you have any duplicates
Next i
'Here you can change where you want to evaluate your data
ColI = 108
ColF = 112
For i = 2 To UBound(arrData) 'loop through rows
For j = ColI To ColF 'loop through columns
arrData(i, j) = arrSource(DictMatches(arrData(i, 3), DictHeaders(1, j)))
Next j
Next i
'Paste the arrData back to the sheet
ThisWorkbook.Sheets("SheetName").UsedRange.Value = arrData
End Sub
This is the fastest way, why?
You store both sheets into the arrays and from then on you work only with the arrays(which means working on memory, so working faster)
Using excel functions always slow downs the process, instead we are storing all the index values on rows and headers for the omzet sheet, so when you point to a value from Column C on your working sheet, it gives you the result without calculating anything.
Here: arrSource(DictMatches(arrData(i, 3), DictHeaders(1, j))) we are giving a row position and column position.
DictMatches(arrData(i, 3) will give you back the row where that match was found inside the dicitonary. DictHeaders(1, j) will give you back the column where that header was found inside the dictionary.
Note: for dictionaries to work you need the Microsoft Scripting Runtime library checked on your references. Also Dictionaries are Case Sensitiveso Hello <> hello.
Related
I am new to VBA and am trying to copy the column from Row 2 onwards where the column header (in Row 1) contains a certain word- "Unique ID".
Currently what I have is:
Dim lastRow As Long
lastRow = ActiveWorkbook.Worksheets("Sheets1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheets1").Range("D2:D" & lastRow).Copy
But the "Unique ID" is not always in Column D
You can try following code, it loops through first row looking for a specified header:
Sub CopyColumnWithHeader()
Dim i As Long
Dim lastRow As Long
For i = 1 To Columns.Count
If Cells(1, i) = "Unique ID" Then
lastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(2, i), Cells(lastRow, i)).Copy Range("A2")
Exit For
End If
Next
End Sub
When you want to match info in VBA you should use a dictionary. Additionally, when manipulating data in VBA you should use arrays. Although it will require some learning, below code will do what you want with minor changes. Happy learning and don't hesitate to ask questions if you get stuck:
Option Explicit
'always add this to your code
'it will help you to identify non declared (dim) variables
'if you don't dim a var in vba it will be set as variant wich will sooner than you think give you a lot of headaches
Sub DictMatch()
'Example of match using dictionary late binding
'Sourcesheet = sheet1
'Targetsheet = sheet2
'colA of sh1 is compared with colA of sh2
'if we find a match, we copy colB of sh1 to the end of sh2
'''''''''''''''''
'Set some vars and get data from sheets in arrays
'''''''''''''''''
'as the default is variant I don't need to add "as variant"
Dim arr, arr2, arr3, j As Long, i As Long, dict As Object
'when creating a dictionary we can use early and late binding
'early binding has the advantage to give you "intellisense"
'late binding on the other hand has the advantage you don't need to add a reference (tools>references)
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
dict.CompareMode = 1 'textcompare
arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source, assuming we have data as of A1
arr2 = Sheet2.Range("A1").CurrentRegion.Value2 'load source2, assuming we have data as of A1
'''''''''''''''''
'Loop trough source, calculate and save to target array
'''''''''''''''''
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can write these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediate array (arr3) to store the results
'We use a "dictionary" to match values in vba because this allows to easily check the existence of a value
'Together with arrays and collections these are probably the most important features to learn in vba!
For j = 1 To UBound(arr) 'traverse source, ubound allows to find the "lastrow" of the array
If Not dict.Exists(arr(j, 1)) Then 'Check if value to lookup already exists in dictionary
dict.Add Key:=arr(j, 1), Item:=arr(j, 1) 'set key if I don't have it yet in dictionary
End If
Next j 'go to next row. in this simple example we don't travers multiple columns so we don't need a second counter (i)
'Before I can add values to a variant array I need to redim it. arr3 is a temp array to store matching col
'1 To UBound(arr2) = the number of rows, as in this example we'll add the match as a col we just keep the existing nr of rows
'1 to 1 => I just want to add 1 column but you can basically retrieve as much cols as you want
ReDim arr3(1 To UBound(arr2), 1 To 1)
For j = 1 To UBound(arr2) 'now that we have all values to match in our dictionary, we traverse the second source
If dict.Exists(arr2(j, 1)) Then 'matching happens here, for each value in col 1 we check if it exists in the dictionary
arr3(j, 1) = arr(j, 2) 'If a match is found, we add the value to find back, in this example col. 2, and add it to our temp array (arr3).
'arr3(j, 2) = arr(j, 3) 'As explained above, we could retrieve as many columns as we want, if you only have a few you would add them manually like in this example but if you have many we could even add an additional counter (i) to do this.
End If
Next j 'go to the next row
'''''''''''''''''
'Write to sheet only at the end, you could add formatting here
'''''''''''''''''
With Sheet2 'sheet on which I want to write the matching result
'UBound(arr2, 2) => ubound (arr2) was the lastrow, the ubound of the second dimension of my array is the lastcolumn
'.Cells(1, UBound(arr2, 2) + 1) = The startcel => row = 1, col = nr of existing cols + 1
'.Cells(UBound(arr2), UBound(arr2, 2) + 1)) = The lastcel => row = number of existing rows, col = nr of existing cols + 1
.Range(.Cells(1, UBound(arr2, 2) + 1), .Cells(UBound(arr2), UBound(arr2, 2) + 1)).Value2 = arr3 'write target array to sheet
End With
End Sub
I am now trying to creating several worksheets and copying data from an existing worksheet to the worksheet that I just created.
This is what I have tried so far:
Sub CreateTemplate()
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "CUST001"
Worksheets("Template").Cells.Copy Worksheets("CUST001").Cells
Worksheets("CUST001").Select
Range("C4") = "='CDE Information'!R[-2]C[-2]"
Range("C5") = "='CDE Information'!R[-3]C[-1]"
Range("C6") = "1111"
Range("C7") = "2222"
End Sub
This is an example of a table that I want to copy.
Table
I also want to create the worksheets and name them by the values of each row in column A.
So, it seems to me that I should do something with loops but I have no idea about that.
Can anyone help me out? Thank you in advance!
Welcome to stack. Try this:
Option Explicit
Sub copyWs()
Dim arr, j As Long
With Sheet1
arr = .Range("A1").CurrentRegion.Value2 'get all data in memory
For j = 1 To UBound(arr) 'traverse rows
.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) 'add ws after the last ws
Sheets(ActiveWorkbook.Sheets(Worksheets.Count).Index).Name = arr(j, 1) 'name the last added ws
Next j
End With
End Sub
Now that we already have an array with all data we can also copy only part of our data to a new sheet instead of copying the whole sheet. To achieve this we'll just create a blank sheet first:
Sheets.Add After:=ActiveWorkbook.Sheets(Worksheets.Count) 'add ws after the last ws
When iterating an array we'll use 2 "counter" variables. 1 to go trough the lines, 1 to go trough the columns.
Dim j As Long, i As Long 'initiate our counter vars
For j = 1 To UBound(arr) 'traverse rows
For i = 1 To UBound(arr, 2) 'traverse columns
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
Next i
Next j
The "Ubound" function allows us to get the total nr of rows and columns.
Dim arr2
ReDim arr2(1 To 1, 1 To UBound(arr)) '=> we only need 1 line but all columns of the source, as we cannot dynamically size an array with the "dim", we redim
For j = 1 To UBound(arr) 'traverse rows
For i = 1 To UBound(arr, 2) 'traverse columns
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can dump these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediant array to store the full line
arr2(1, i) = arr(j, i)
Next i
'when we have all the columns we dumb to the sheet
With Sheets(arr(j, 1)) 'the with allows us the re-use the sheet name without typing it again
.Range(.Cells(1, 1), .Cells(UBound(arr2), UBound(arr2, 2))).Value2 = arr2 'the ubound function allows us to size the "range" to the same size as our array, once that's done we can just dumb it to the sheet
End With
Next j
I need to copy the Employee Name in Column I until a new Employee Comes up. For example, Copy Brown, Nat till row 8 i.e. Code: Shift 1, then start copying Brown, Rob. I used If with find function but i cant make it work.
Your question is mighty short on detail but the function below should help you get one step nearer to what you need. Please try it.
Private Function EmployeeData(ByVal FirstRow As Long) As Variant
' 233
Dim Arr As Variant
Dim Cl As Long ' last used column
Dim R As Long ' lop counter: rows
With Worksheets("Sheet1")
Arr = .Range(.Cells(1, "I"), .Cells(.Rows.Count, "I").End(xlUp)).Value
R = FirstRow
Do
If InStr(1, Arr(R + 1, 1), "Employee Name:", vbTextCompare) = 1 Then Exit Do
R = R + 1
Loop While R < UBound(Arr)
With .UsedRange
Cl = .Columns.Count + .Column - 1
End With
EmployeeData = .Range(.Cells(FirstRow, "A"), .Cells(R, Cl)).Value
End With
End Function
The function takes one argument. That is the number of the row where the employee's name is first found. Starting from that row, the function searches until the next name is found in column I and returns the data from the rows in between. It returns all data, from column A to the last used column.
Use the procedure below to test. Observe that EmployeeData(14) specifies row 14 as the first row of a block and that the loop that follows just prints column I:I although the array contains all the columns.
Sub GetData()
' 233
Dim Arr As Variant
Dim R As Long
Arr = EmployeeData(14)
For R = 1 To UBound(Arr)
Debug.Print Arr(R, 9)
Next R
End Sub
In real life, you will probably need to search for the first row before you can run this code. That search, if needed, is easy to integrate into the test procedure.
I am attempting to run a VBA macro that iterates down about 67,000 rows with 100 columns in each row. For each of the cells in these rows, the value is compared against a column with 87 entries in another sheet. There are no errors noted when the code is run but Excel crashes every time. The odd thing is that the code seems to work; I have it set to mark each row in which a match is found and it does so before crashing. I have attempted to run it many times and it has gotten through between 800 and 11,000 rows before crashing, depending on the attempt.
My first suspect was memory overflow due to the volume of calculations but my system shows CPU utilization at 100% and memory usage around 50% while running this code:
Sub Verify()
Dim codes As String
Dim field As Object
For i = 2 To Sheets("DSaudit").Rows.Count
For Each field In Sheets("Dsaudit").Range(Cells(i, 12), Cells(i, 111))
r = 1
While r <= 87
codes = ThisWorkbook.Sheets("287 Denominator CPT").Cells(r, 1).Value
If field = codes Then
Cells(i, 112).Value = "True"
r = 88
Else
r = r + 1
End If
Wend
Next field
i = i + 1
Next i
End Sub
It should also be noted that I am still very new to VBA so it's likely I've made some sort of egregious rookie mistake. Can I make some alterations to this code to avoid a crash or should I scrap it and take a more efficient approach?
When ever possible iterate variant arrays. This limits the number of times vba needs to access the worksheet.
Every time the veil between vba and Excel is pierced cost time. This only pierces that veil 3 times not 9,031,385,088
Sub Verify()
With Sheets("DSaudit")
'Get last row of Data
Dim lastrow As Long
lastrow = .Cells(.Rows.Count, 12).End(xlUp).Row 'if column 12 ends before the last row of data change to column that has them all.
'Load Array with input Values
Dim rng As Variant
rng = .Range(.Cells(2, 12), .Cells(lastrow, 111)).Value
'Create output array
Dim outpt As Variant
ReDim outpt(1 To UBound(rng, 1), 1 To 1)
'Create Match array
Dim mtch As Variant
mtch = Worksheets("287 Denominator CPT").Range("A1:A87").Value
'Loop through first dimension(Row)
Dim i As Long
For i = LBound(rng, 1) To UBound(rng, 1)
'Loop second dimension(Column)
Dim j As Long
For j = LBound(rng, 2) To UBound(rng, 2)
'Loop Match array
Dim k As Long
For k = LBound(mtch, 1) To UBound(mtch, 1)
'If eqaul set value in output and exit the inner loop
If mtch(k, 1) = rng(i, j) Then
outpt(i, 1) = "True"
Exit For
End If
Next k
'If filled true then exit this for
If outpt(i, 1) = "True" Then Exit For
Next j
Next i
'Assign the values to the cells.
.Cells(2, 112).Resize(UBound(outpt, 1), 1).Value = outpt
End With
End Sub
I have been stuck on this for weeks and have tried many formula combinations but can't get this to work. I don't know VBA so don't know where to start there.
I have List 1 and List 2 below. I need List 3 to be created from the data in Lists 1 and 2. List 3 can, preferably, be created in a new sheet.
I need to lookup the criteria from Column A, in List2 (Column D) then return all matches in a new list that shows: List 1; the criteria (Column A), data in Column B; and all matches from List 2 (Column E)
See Below. List 3 is the outcome
I broke this into two parts and I tried using a formula that copied the row the amount of times that there was a match. Then I was going to copy paste or find some vba or formula to combine the table but I came to a dead end when I realized the they tables weren't sorted in the same order. I ended up with these two lists to combine
Tried this VBA
Getting this error
Try This.
Run the macro "Test"
The first parameter should be the range of your first list (Just the numbers)
The second parameter should be the range of your second list (Just the numbers)
OutputSheet should be the sheet you want to output the list on
You can also optionally set the output row and output column (It will start at A1 if you don't specify)
Sub CreateList(List1 As Range, List2 As Range, OutputSheet As Worksheet, Optional ORow As Long = 1, Optional OCol As Long = 1)
Dim c, d
For Each c In List1
For Each d In List2
If c = d Then
OutputSheet.Cells(ORow, OCol).Value = c.Value
OutputSheet.Cells(ORow, OCol + 1).Value = c.Offset(0, 1).Value
OutputSheet.Cells(ORow, OCol + 2).Value = d.Offset(0, 1).Value
ORow = ORow + 1
End If
Next d
Next c
End Sub
Sub Test()
With Sheets("Sheet1")
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
End With
End Sub
The code loops through each number in the first list, and then each number in the second list.
If the numbers are the same, it outputs the number, the item, and the price.
First it will check If 10 = 10 Then - output the number, output the text next to the number on the first list, and output the amount next to the number on the second list.
Then it increases the row by 1.
That's pretty much all there is to it - just make sure you specify the ranges properly and change the sheet references as needed.
If you have never used VBA before, you can open the window by pressing ALT+F11
Right click to the left side and select Insert -> Module
Paste the code into the right side.
Update the ranges on the following line so they match where your lists are:
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
You can then close the window and press ALT+F8 to open the Run Macro dialog.
Select Test and click Run
Input:
Results:
What about this?
The code below assumes that on Sheet1, data starts from Row2 where Row1 is the header row.
Sub CreateList()
Dim x, y, z()
Dim i As Long, j As Long, k As Long, n As Long, dlr As Long
Dim wsData As Worksheet, wsOutput As Worksheet
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("List")
wsOutput.Cells.Clear
On Error GoTo 0
If wsOutput Is Nothing Then
Sheets.Add(after:=wsData).Name = "List"
Set wsOutput = ActiveSheet
End If
x = wsData.Range("A1").CurrentRegion.Value
y = wsData.Range("D1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If Application.CountIf(wsData.Columns("D"), x(i, 1)) > 0 Then
n = Application.CountIf(wsData.Columns("D"), x(i, 1))
ReDim z(1 To n)
k = 1
For j = 2 To UBound(y, 1)
If y(j, 1) = x(i, 1) Then
z(k) = y(j, 2)
k = k + 1
End If
Next j
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
wsOutput.Range("A" & dlr).Value = x(i, 1)
wsOutput.Range("B" & dlr).Value = x(i, 2)
wsOutput.Range("C" & dlr).End(3)(2).Resize(UBound(z, 1), 1) = Application.Transpose(z)
End If
Erase z
Next i
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
If dlr > 1 Then
wsOutput.Range("A2:C" & dlr).CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
wsOutput.Rows(1).Delete
End If
Application.ScreenUpdating = True
End Sub