VBA How to check for duplicate values against existing list and add only unique instances from new list - excel

I have three worksheets with consistent headers, but the # of columns vary:
Active List
Current List
New List
I need to compare column A from "New List" against Column B from "Active List" for duplicate instances.
I want to load only the unique instances from column A starting at row 2 along with the associated cells in Column B on my "New List" beneath the last, populated row of my "Active List" worksheet in columns B & C.
To do this, I have tried utilizing the Scripting Dictionary, but I receive Run Time Error 1004 on my object range in the following line of code:
Dict.Add Key:=NL.Range(i, "A").Value, Item:=vbNullString
Here is the full code which I mimicked from question #55499372 on StackOverflow:
Sub load_new()
Dim LastRow As Long
Dim i As Long
Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Dim CL As Worksheet
Set CL = ThisWorkbook.Worksheets("CURRENT LIST")
Dim NL As Worksheet
Set NL = ThisWorkbook.Worksheets("NEW LIST")
Dim AL As Worksheet
Set AL = ThisWorkbook.Worksheets("ACTIVE LIST")
'Retrieves the last row of column A
With NL
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 2 To LastRow
Dict.Add Key:=NL.Range(i, 1).Value, Item:=vbNullString
Next i
'Retrieves the last row of column B
With AL
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
For i = 2 To LastRow
If Not Dict.Exists(AL.Range(i, 2).Value) Then
End If
Next i
End Sub

Load the dictionary with keys from Active List column B, then scan the New List column A checking if key does not exist.
Option Explicit
Sub load_new()
Dim wsCL As Worksheet, wsNL As Worksheet, wsAL As Worksheet
Dim LastRowAL As Long, LastRowNL As Long
Dim i As Long, n As Long, key As String
Dim Dict As Scripting.dictionary
Set Dict = New Scripting.dictionary
With ThisWorkbook
'Set wsCL = .Sheets("CURRENT LIST")
Set wsNL = .Sheets("NEW LIST")
Set wsAL = .Sheets("ACTIVE LIST")
End With
' Active List
With wsAL
LastRowAL = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRowAL
key = Trim(.Cells(i, "B"))
If Len(key) > 0 Then
Dict.Add key, i
End If
Next i
End With
' New List
With wsNL
LastRowNL = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowNL
key = Trim(.Cells(i, "A"))
If Not Dict.Exists(key) Then
LastRowAL = LastRowAL + 1
wsAL.Cells(LastRowAL, "B") = key
wsAL.Cells(LastRowAL, "C") = .Cells(i, "B")
n = n + 1
End If
Next i
End With
MsgBox n & " rows added to " & wsAL.Name
End Sub

Related

Copy values and paste to matching worksheet name

I am trying to make VBA to copy data and paste to matching worksheet name.
"Setting" Worksheet will have all mixed data of item types.
With VBA, copy & paste values on A & D columns to matching worksheet name.
VBA code will go through entire A7 -> lastrow
worksheet name is based on the item types.
Right now, I am stuck on this part - setting supplier as dynamic worksheet
Below is the issue area: "out of range"
For i = 7 To lastrow1
'setting spl as the value of the item type
spl = Cells(i, "A").Value
'setting supplier as the worksheet name
Set supplier = Sheets(spl)
Below is the entire VBA code:
I have found an existing code, and had been tweaking to fit my usage.
Sub Copy_Data()
Dim lastrow1 As Long, i As Long, auxRow As Long, offsetRow As Long
Dim spl As String
Dim supplier As Worksheet
Set ws = Sheets("SETTING")
lastrow1 = ws.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 7 To lastrow1
'setting spl as the value of the item type
spl = Cells(i, "A").Value
'setting supplier as the worksheet name
Set supplier = Sheets(spl)
auxRow = supplier.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If auxRow > 1 Then auxRow = auxRow + 1
If auxRow = 1 Then auxRow = offsetRow
supplier.Cells(auxRow, "A") = ws.Cells(i, "A")
supplier.Cells(auxRow, "B") = ws.Cells(i, "D")
Next i
End Sub
Thank you all in an advance.
I have tried to define the worksheet to have dynamic value - based on item type on column A.
But keep receiving 'out of range' when setting the worksheet.
"out of range" because you are opening one sheet from the list. you need to open setting sheet when you run this code.
Another thing don't use Find function
ws.Columns("A").Find("*", searchorder:=xlByRows, earchdirection:=xlPrevious).Row
because returns either of the following outcomes:
If a match is found, the function returns the first cell where the value is located.
If a match is not found, the function returns nothing.
That's will give you error because you define lastrow1 and auxRow as long
instead use this
lastrow1 = ws.Range("A" & Rows.Count).End(xlUp).Row
Try to use this code
Sub Copy_Data()
Dim lastrow1 As Long, i As Long, auxRow As Long, offsetRow As Long
Dim spl As String
Dim supplier As Worksheet
Dim ws As Worksheet
Set ws = Sheets("SETTING")
lastrow1 = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 7 To lastrow1
'setting spl as the value of the item type
spl = Cells(i, "A").Value
'setting supplier as the worksheet name
Set supplier = Sheets(spl)
auxRow = supplier.Range("A" & Rows.Count).End(xlUp).Row + 1
supplier.Cells(auxRow, "A") = ws.Cells(i, "A")
supplier.Cells(auxRow, "B") = ws.Cells(i, "D")
Next i
End Sub
Please, test the next code. If follows the scenario I tried describing in my above comment: place the range to be processed in an array, iterate it and place the necessary data in the dictionary, then drop the processed result in each appropriate sheet. Working only in memory, until dropping the processed result makes it very fast, even for large data:
Sub distributeIssues()
Dim shS As Worksheet, lastR As Long, wb As Workbook, arr, arrIt, arrFin, i As Long
Dim key, dict As Object
Set wb = ThisWorkbooks
Set shS = wb.Sheets("SETTING")
lastR = shS.Range("A" & shS.rows.count).End(xlUp).row 'last row
arr = shS.Range("A7:D" & lastR).Value2 'place the range in an array for faster iteration/processing
'place the range to be processed in dictionary:
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr) 'iterate between the array rows
If Not dict.Exists(arr(i, 1)) Then 'if key does not exist
dict.Add arr(i, 1), Array(arr(i, 4)) 'create it and place the value in D:D as array item
Else
arrIt = dict(arr(i, 1)) 'place the item content in an array
ReDim Preserve arrIt(UBound(arrIt) + 1) 'extend the array with an element
arrIt(UBound(arrIt)) = arr(i, 4) 'place value from D:D in the last element
dict(arr(i, 1)) = arrIt 'place back the array as dictionary item
End If
Next i
'Stop
'drop the necessary value in the appropriate sheet:
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For Each key In dict
With wb.Worksheets(key).Range("B9").Resize(UBound(dict(key)) + 1, 1)
.Value = Application.Transpose(dict(key))
.Offset(, -1).Value = key
End With
Next key
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it.
If something not clear enough, do not hesitate to ask for clarifications.
The items can be in any order. No necessary to be sorted...

Application Match Function how to copy paste data

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

Print value blocks into new worksheets?

I have a worksheet that I need to split out into new ones by column C values. There are 8 values, so I'll need 8 worksheets. Each value has about 2-5000 corresponding rows, so this script isn't ideal because it prints row-by-row.
Sub SplitData()
Const iCol = 3 ' names in second column (B)
Const sRow = 2 ' data start in row 2
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Dim i As Long
Dim lRow As Long
Dim lngTargetRow As Long
Application.ScreenUpdating = False
Set wshSource = Sheets(1)
lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row
For i = sRow To lRow
If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wshTarget.Name = wshSource.Cells(i, iCol).Value
wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
lngTargetRow = 2
End If
wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
lngTargetRow = lngTargetRow + 1
Next i
Application.ScreenUpdating = True
End Sub
How would I change this up to print each value block (column C) to each worksheet instead of every row (i) individually? Would I need to implement auto-filtering by column C values and do a loop that way?
Try this out, as you well pointed, filtering would be the fastest way here:
Option Explicit
Sub Test()
Dim uniqueValues As Object
Set uniqueValues = CreateObject("Scripting.Dictionary")
Dim i As Long
With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data
'First let's store the unique values inside a dictionary
For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
Next i
'Now let's loop through the unique values
Dim Key As Variant
For Each Key In uniqueValues.Keys
.UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
.UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
Next Key
End With
End Sub

VBA code for saving specific range of rows

Question regarding the code below. I need this randomizer to save the random entries that it created on a separated file without deleting previous entries that got saved, how should I proceed?
Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim shAudit As Worksheet
Dim shData As Worksheet
Dim r As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim key As Variant
name = Range(A5, H9).Value
Set shAudit = ThisWorkbook.Sheets("Sheet1")
Set shData = ThisWorkbook.Sheets("Sheet2")
lastRow = shData.Range("A" & shData.Rows.Count).End(xlUp).Row
'Pick 5 random records with no repeats
Do Until dict.Count = 5
r = Application.WorksheetFunction.RandBetween(2, lastRow)
If Sheets("Sheet1").Range("A2") = Sheets("Sheet2").Cells(r, "G") Then
If Not dict.Exists(r) Then
dict.Add r, r
End If
End If
Loop
r = 0
For Each key In dict.Keys
shData.Range("A1:H1").Offset(key - 1, 0).Copy shAudit.Range("A5:H5").Offset(r, 0)
r = r + 1
Next key
End Sub
You can add this line just before End Sub. Change the sheet name to suit.
Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp)(2).Resize(dict.Count) = Application.Transpose(dict.keys)

Delete section of data based on one entry in section meeting certain criteria using excel vba

I have one excel sheet (lets say sheet A) that has data in it, organized into groupings separated by an empty row and grouped by a common entry in column N. Within each grouping, I need to check another excel sheet (lets say sheet B) in a different workbook to see if any of the entries in column A of sheet A matches any entries in sheet B's column C. If any of the column C entries match those of the column A entries in a single grouping of the first sheet, I do not do anything to that grouping. If there are no matches, I need to delete the whole grouping. Below is my attempt, but I am mostly getting confused with 1. how to delete just a grouping and 2. how to call to each sheet/column correctly.
Sub DeleteAdjacent()
Dim wb1 As Workbook, Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long, Dim lastrow2 As Long, Dim i As Long, Dim j As Long
Set wb1 = Workbooks("Workbook1.xlsx")
Set wb2 = Workbooks("Workbook2.xlsx")
Set sh2 = wb2.Sheets(“Sheet B”)
Set sh1 = wb1.Sheets("Sheet A")
lastrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
For j = lastrow1 To 1 Step -1
cell = "N" & j
cell1 = "N" & (j - 1)
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
For i = lastrow2 To 1 Step -1
cell2 = "C" & i
cell3 = "A" & j
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range(j, cell).EntireRow.Delete
Loop
End If
Next i
Loop
Next j
End Sub
Edit: Looking at my attempt more closely, it would actually do the opposite of what I'd want to do. I attempted to delete the entire grouping when there was a match, when I actually want the exact opposite. I think then the part below should be changed.
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
My attempt at correcting this is maybe too simple?
If sh1.Cells(j, cell3).Value <> sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
I think if I were attacking this problem I wouldn't compare A with C and do the group looping check in the same process. It might be easier to get your head around the issue if you create a map of values to groups first. Say a value of 10 exists in groups 1,3 and 5, then you could just check for a 10 and immediately eliminate 3 groups from your future checks. A Collection of Collections would serve you well for this as the look up by key is very fast and you don't have to worry about the number of items it stores.
If you also had a collection of Ranges for each group then it would be a simple process of eliminating matching groups and then, in one hit, delete all the remaining Ranges.
The code below should do that for you (but as with any row delete code, I'd suggest you back up your raw data first!):
Public Sub DeleteAdjacent()
Dim ws As Worksheet
Dim valueGroupMap As Collection
Dim groupRanges As Collection
Dim values As Collection
Dim lastRow As Long
Dim groupRng As Range
Dim valueCell As Range
Dim groupCell As Range
Dim rng As Range
Dim v As Variant
Dim r As Long
'Read the Column A worksheet
Set ws = Workbooks("Workbook1.xlsx").Worksheets("Sheet A")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1 '+1 to get a blank row at end
'Define the value map group ranges
Set valueGroupMap = New Collection
Set groupRanges = New Collection
Set groupRng = ws.Cells(1, "N")
For r = 1 To lastRow
Set valueCell = ws.Cells(r, "A")
Set groupCell = ws.Cells(r, "N")
If Len(CStr(groupCell.Value2)) = 0 Then
'We've reached the end of a group
Set rng = ws.Range(groupRng, groupCell.Offset(-1))
groupRanges.Add rng, CStr(groupRng.Value2)
Set groupRng = Nothing
Else
'We're working within a group
If groupRng Is Nothing Then
Set groupRng = groupCell
End If
'Create the value to group map
Set values = Nothing
On Error Resume Next
Set values = valueGroupMap(CStr(valueCell.Value2))
On Error GoTo 0
If values Is Nothing Then
Set values = New Collection
valueGroupMap.Add values, CStr(valueCell.Value2)
End If
values.Add CStr(groupRng.Value2)
End If
Next
'Read the Column C worksheet
Set ws = Workbooks("Workbook2.xlsx").Worksheets("Sheet B")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For r = 1 To lastRow
'Check if we have the value
Set values = Nothing
Set values = valueGroupMap(CStr(ws.Cells(r, "C").Value2))
If Not values Is Nothing Then
'We do, so remove the group ranges from our list
For Each v In values
groupRanges.Remove CStr(v)
Next
End If
Next
On Error GoTo 0
'Create a range of the groups still remaining in the list
Set rng = Nothing
For Each groupRng In groupRanges
If rng Is Nothing Then
Set rng = groupRng
Else
Set rng = Union(rng, groupRng)
End If
Next
'Delete that range
rng.EntireRow.Delete
End Sub

Resources