I am new to VBA Dictionaries. What I am trying to do is evaluate each row of a sheet. If the value in Column J is "100", then I want to create a key/item entry into the dictionary. If any other value is in Column J, I do not want the entry to be created and for the macro to look at the next row of data.
I currently have the code below:
Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRowTwo As Long, shtOrders As Worksheet, shtReport As Worksheet
Set shtOrders = Worksheets("Orders")
Set shtReport = Worksheets("Mapping")
Set dict = CreateObject("Scripting.Dictionary")
With shtReport
LastRow = .Range("G" & Rows.Count).End(xlUp).Row
x = .Range("G2:G" & LastRow).Value
x2 = .Range("I2:I" & LastRow).Value
Set SelectionRNG = Worksheets("Mapping").Range("G2:J" & LastRow)
For Each rngrow In SelectionRNG.Rows
If rngrow.Cells(1, 4) = "100" Then
dict.Item(x(i, 1)) = x2(i, 1)
End If
Next
End With
I know that this line:
dict.Item(x(i, 1)) = x2(i, 1)
Is where my problem is. I have used that syntax in the code below and it works fine:
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x2(i, 1)
Next i
I am stuck on how to change the syntax of either my "rngrow code" to add a dictionary entry without using the "i" or to adjust the code directly above to include an IF statement to check the value in column J (and only create an entry if J = 100 for the row currently being assessed.
If the code above was not clear, the key would be in Column G and the item would be in column I. (I later lookup Column G and retrieve column I's value.)
As I said, I am new to this, so I appreciate any help!
Cheers!
I would get rid of rngrow and just loop through rows 2 to LastRow:
Dim i As Long
Dim dict As Object
Dim LastRow As Long, shtReport As Worksheet
Set shtReport = Worksheets("Mapping")
Set dict = CreateObject("Scripting.Dictionary")
With shtReport
LastRow = .Range("G" & .Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, "J") = "100" Then
dict.Item(.Cells(i, "G").Value) = .Cells(i, "I").Value
End If
Next
End With
Related
What is worng with my function its loading the two different column A and B and pasting the unique values of column A into Column M and N.
I want to repeat this function for the 7 columns.
I would appreciate your help in this regards.
Sub GetUniques()
Dim d As Object, c As Variant, i As Long, lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
lr2 = Cells(Rows.Count, 2).End(xlUp).Row
e = Range("B2:B" & lr2)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
For i = 1 To UBound(e, 1)
d(e(i, 1)) = 1
Next i
Range("M2").Resize(d.Count) = Application.Transpose(d.keys)
Range("N2").Resize(d.Count) = Application.Transpose(d.keys)
End Sub
It looks like your plan is to have a lr variable for each column as well as loops and transpose statements. You can avoid this by nesting your code in a column loop.
The current Column range is hard coded here (A to E) but this can be updated to be dynamic as needed. The output is also hard coded to be dropped 9 columns to the right of the input column. This aligns with A to J, B to K, etc.
Sub GetUniques()
Dim c As Variant, i As Long, lr As Long, col As Long
Dim d As Object
For col = 1 To 5 'Column A to E
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, col).End(xlUp).Row
c = Range(Cells(2, col), Cells(lr, col))
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Cells(2, col + 9).Resize(d.Count) = Application.Transpose(d.keys)
Set d = Nothing
Next col
End Sub
I am adding the UNIQUE- solution - for completeness:
You can either use a manual formula in J2: =UNIQUE(A:E,TRUE) - the second parameter tells UNIQUE to put out unique values per column --> it will spill from J to N.
You can use this formula in a VBA-routine as well:
Public Sub writeUniqueValues(rgSource As Range, rgTargetTopLeftCell As Range)
With rgTargetTopLeftCell
.Formula2 = "=UNIQUE(" & rgSource.Address & ",TRUE)"
With .SpillingToRange
.Value = .Value 'this will replace the formula by values
End With
End With
End Sub
You can then use this sub like this:
Public Sub test_writeUniqueValues()
With ActiveSheet 'be careful: you should always use explicit referencing
Dim lr As Long
lr = .Cells(Rows.Count, 1).End(xlUp).Row
writeUniqueValues .Range("A2:E" & lr), .Range("J2")
End With
End Sub
It would be interesting to compare performance of both solutions (using the formula vs. using a dictionary) ...
Using Application.Match Function but unable to know how to paste the Col"M" data into Col"P" after the Matching the Col"O" and Col"L".
When run the Current function it gives the count of match.
Any help will be appreciated.
Dim k As Integer
For k = 2 To 9
ws2.Cells(k, 16).Value = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
Next k
I have edited the code with the columns and in which column the result is required. But unable to make changes I really appreciate your help that you make this function. I added some comments may it can help.
' Sheet2 Col"C" with ID's
With ws2
Dim lastRow As Long
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim originalData() As Variant
originalData = .Range("C2:C" & lastRow).Value
End With
' Sheet2 Col"C" with ID's
With ws3
Dim lastRow2 As Long
lastRow2 = .Range("A" & .Rows.Count).End(xlUp).Row
Dim newData() As Variant
newData = .Range("C2:C" & lastRow2).Value
End With
Dim i As Long
For i = LBound(newData, 1) To UBound(newData, 1)
Dim j As Long
For j = LBound(originalData, 1) To UBound(originalData, 2)
If newData(i, 1) = originalData(j, 1) Then
newData(i, 2) = originalData(j, 2)
Exit For
End If
Next
Next
'Sheet2 Col"K" where Sheet3 Col"E" data will be pasted
ws2.Range("K2:K" & lastRow).Value = newData
A scripting dictionary which maps "keys" to "values" is typically the fastest approach when you need to perform a lot of lookups. It's a bit more code to write but should be quick.
Sub DoLookup()
Dim arrKeys, arrValues, wsData As Worksheet, wsDest As Worksheet
Dim map As Object, rngSearch As Range, rngResults As Range, k, v, n As Long
Set wsData = ThisWorkbook.Worksheets("Sheet3") 'sheet with the lookup table
Set wsDest = ThisWorkbook.Worksheets("Sheet2") 'sheet to be populated
arrKeys = wsData.Range("C2:C" & LastRow(wsData, "C")).Value 'keys in the lookup table
arrValues = wsData.Range("G2:G" & LastRow(wsData, "C")).Value 'values in the lookup table
Set map = MapValues(arrKeys, arrValues) 'get a map of Keys->Values
Set rngSearch = wsDest.Range("C2:C" & LastRow(wsDest, "c")) 'keys to look up
Set rngResults = rngSearch.EntireRow.Columns("K") 'results go here
arrKeys = rngSearch.Value 'keys to look up
arrValues = rngResults.Value 'array to populate with results
For n = 1 To UBound(arrKeys) 'loop over keys to look up
v = "" 'or whatever you want to see if no match
k = arrKeys(n, 1)
If map.exists(k) Then v = map(k)
arrValues(n, 1) = v
Next n
rngResults.Value = arrValues 'populate the results array back to the sheet
End Sub
'Return a Scripting Dictionary linking "keys" to "values"
' Note - assumes same-size single-column inputs, and that keys are unique,
' otherwise you just map to the *last* value for any given key
Function MapValues(arrKeys, arrValues)
Dim n, dict As Object, k
Set dict = CreateObject("scripting.dictionary")
For n = 1 To UBound(arrKeys, 1)
k = CStr(arrKeys(n, 1)) 'string keys are faster to add?
If Len(k) > 0 Then dict(k) = arrValues(n, 1)
Next n
Set MapValues = dict
End Function
'utility function
Function LastRow(ws As Worksheet, col As String) As Long
LastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function
In my test workbook this was able to perform 10k lookups against a table of 10k rows in <0.1 sec.
You always should test if the Match succeeded, using IsError.
Then use Cells:
Dim k As Long
For k = 2 To 9
Dim m As Variant
m = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
If Not IsError(m) Then
ws2.Cells(k, 16).Value = ws2.Range("M2:M9").Cells(m)
End If
Next
I'm trying to highlight the entire row grey if the value in column A begins with "ABC" as well as delete everything right of that cell. Any ideas on how to do this?
Dim DataRange As Range
Set DataRange = Range("A1:U" & LastRow)
Set MyRange = Range("A2:A" & LastRow)
For Each Cell In MyRange
If UCase(Left(Cell.Value, 3)) = "ABC" Then
Cell.EntireRow.Interior.ColorIndex = 15
Else
End If
Next
Here is pretty straightforward approach:
Dim lastRow As Long
Dim row As Long
Dim temp As String
' insert your sheet name here
With ThisWorkbook.Worksheets("your sheet name")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' you can change the starting row, right now its 1
For row = 1 To lastRow
' store whats in col A in a temporary variable
temp = Trim(CStr(.Range("A" & row).Value))
' if col A isn't 'ABC' clear & grey entire row
If UCase(Left(.Range("A" & row).Value), 3) <> "ABC" Then
.Rows(row).ClearContents
.Rows(row).Interior.ColorIndex = 15
' place temp variable value back in col A and make interior No Fill
.Range("A" & row).Value = temp
.Range("A" & row).Interior.ColorIndex = 0
End If
Next
End With
Here is another example; you stated "clear everything to the right" so I added offset to clear the contents of the cells not in column A.
Dim x As Long
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If UCase(Left(Cells(x, 1).Value, 3)) = "ABC" Then
Range(Cells(x, 1), Cells(x, Columns.Count).End(xlToLeft)).Interior.ColorIndex = 15
Range(Cells(x, 1).Offset(, 1), Cells(x, Columns.Count).End(xlToLeft)).ClearContents
End If
Next x
I need to compare the data with unique identifier which is the concatenation of (Column A, "~" Column B) and store it in Column F. Find all the duplicate values in ColumnF, which will used as a basis for comparing to the other Columns (Column C, Column D and Column E). For example,
In my example, I have a duplicate value of 5*2018~OPS$CABUCKLE, in this case I will compare each column using the identifier. In my 1st entry, Column C have the same value in 2nd entry which is 222, but in Column D the value of 1st entry is N and it was changed to Y in 2nd entry. Same case in Column E. I need to highlight the changes happened between the entries.
I only did the concatenation in VBA, but I don't know how will I find the duplicate value and compare the other column?
Sub split1()
Dim ws As Worksheet, lRow As Long
Dim x As Long
Set ws = ThisWorkbook.ActiveSheet
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
With ws
For x = 1 To lRow
For Each wrd In .Cells(x, 1)
d = wrd
For Each nm In .Cells(x, 2)
.Cells(x, 6).Value = d & "*" & nm
Next nm
Next
Next x
End With
End Sub
This could achieve what you're looking for, let me know if it misses anything
Just don't forget to go to Tools > References and check 'Microsoft Scripting Runtime'
Sub highlight()
' need to include Microsoft Scripting Runtime in Tools > References
Dim prevIDs As Scripting.Dictionary: Set prevIDs = New Scripting.Dictionary
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Dim lastRow As Long
Dim oldRow As Long
Dim row As Long
Dim id As String
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).row
For row = 2 To lastRow
' set lookup value
.Cells(row, "F").Value = Trim(CStr(.Cells(row, "A").Value)) & "~" & Trim(CStr(.Cells(row, "B").Value))
id = .Cells(row, "F").Value
If prevIDs.Exists(id) Then
' get previously found row
oldRow = prevIDs(id)
If .Cells(row, "C").Value = .Cells(oldRow, "C").Value Then
' only checks if col D doesn't match -- can change to check both
If .Cells(row, "D").Value <> .Cells(oldRow, "D").Value Then
.Range("D" & row & ":E" & row).Interior.Color = RGB(100, 200, 100)
.Range("D" & oldRow & ":E" & oldRow).Interior.Color = RGB(100, 200, 100)
End If
End If
' reset last found row
prevIDs(id) = row
Else
prevIDs.Add id, row
End If
Next
End With
End Sub
Here's my test:
I have column A that has all existing categories, new categories are listed in column C. I'm trying to determine how to take these new categories, and add them to column "a" if they aren't already in column A. In the example the new categories in column C are added to column A even if there are already in column A. I would also need range("a1") in the if-then line to be a dynamic range since new categories will be added as the code runs. Some constructive criticism would be greatly appreciated as well to help me in the future.
Sub newcategory()
Dim newcatcount As Integer
Dim i As Integer
newcat = Range("c100000").End(xlUp).Row
For i = 1 To newcat
If Cells(i, 3).Value <> Range("a1") Then
Cells(i, 3).Select
Selection.copy
Range("a100000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Please give this a try...
Sub AddNewCategories()
Dim lrA As Long, lrC As Long, i As Long, j As Long
Dim x, y, z(), dict
lrA = Cells(Rows.Count, 1).End(xlUp).Row
lrC = Cells(Rows.Count, 3).End(xlUp).Row
'Array to hold the categories in column A starting from Row1, assuming the categories start from A1. If not, change it accordingly.
x = Range("A1:A" & lrA).Value
'Array to hold the new categories in column C starting from Row1, assuming the categories start from C1. If not, change it accordingly.
y = Range("C1:C" & lrC).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For i = 1 To UBound(y, 1)
If Not dict.exists(y(i, 1)) Then
dict.Item(y(i, 1)) = ""
j = j + 1
ReDim Preserve z(1 To j)
z(j) = y(i, 1)
End If
Next i
If j > 0 Then
Range("A" & lrA + 1).Resize(j).Value = Application.Transpose(z)
End If
Set dict = Nothing
End Sub
you could use excel built in RemoveDuplicates() function, as follows (mind the comments):
Option Explicit
Sub newcategory()
Dim newcat As Range
With Worksheets("Categories") ' change "Categories" to your actual sheeet name
Set newcat = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp)) ' get the range of all nwe categories in reference sheet column C from row 1 down to last not empty one
.Cells(.Rows.Count, 1).End(xlUp).Resize(newcat.Rows.Count).Value = newcat.Value ' append new categories values below existing categories in column A
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo ' remove duplicates
End With
End Sub