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)
Related
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
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
Hello VBA Developers,
I am having a hard time solving a multi-wildcard filter for criteria(s) listed in an array. The code stops at "vTst = Doc_ID_Arr(i)", stating vTst = Empty. However, checking Doc_ID_Arr is not empty if you check the debugger.
Sub doc_id()
'Segment 1 ----
'Get the worksheet called "LOB Docs"
Dim sh_1 As Worksheet
Set sh_1 = ThisWorkbook.Worksheets("LOB Docs")
' Declare an array to hold all LOB Doc ID numbers
Dim Doc_ID_Arr As Variant
Dim Doc_ID_Value As String
Dim j As Long
Dim i As Long
With sh_1
lastrow_Header_Config = sh_1.Cells(Rows.count, "A").End(xlUp).Row
' Read LOB DOC ID's from Column Cell A2 to last value in Column A
ReDim Doc_ID_Arr(Application.WorksheetFunction.CountA(sh_1.Range("A2:A" & lastrow_Header_Config)) - 1) As Variant
j = 0
For i = 2 To lastrow_Header_Config
Doc_ID_Value = sh_1.Range("A" & i).Value
If Doc_ID_Value <> "" Then
Doc_ID_Arr(j) = "*" & Doc_ID_Value & "*"
j = j + 1
End If
Next
End With
' ' Debug.Print "Doc_ID_Value"
' For i = LBound(Doc_ID_Arr) To UBound(Doc_ID_Arr)
' Debug.Print Doc_ID_Arr(i)
' Next i
'Segment 2 ----
Dim sh_2 As Worksheet 'Data Sheet
Dim sh_3 As Worksheet 'Output Sheet
Set sh_2 = ThisWorkbook.Worksheets("GDL db") 'Data Sheet
Set sh_3 = ThisWorkbook.Worksheets("Seed Template Output")
Dim Dic As Object
Dim eleData As Variant
Dim eleCrit As Variant
Dim ArrData As Variant
Dim vTst As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Dim x As Long
For x = LBound(Doc_ID_Arr) To UBound(Doc_ID_Arr)
vTst = Doc_ID_Arr(i)
Next x
With sh_2
.AutoFilterMode = False
ArrData = .Range("A1:A" & .Cells(.Rows.count, "A").End(xlUp).Row)
For Each eleCrit In vTst
For Each eleData In ArrData
If eleData Like eleCrit Then _
Dic(eleData) = vbNullString
Next
Next
.Columns("A:A").AutoFilter Field:=1, Criteria1:=Dic.Keys, Operator:=xlFilterValues
sh_2.UsedRange.Copy sh_3.Range("A1")
End With
End Sub
I am trying to filter sh_2, Column A for each value(individual) or all values(en masse) that is placed in the Doc_ID_Arr created in Segment 1. The target is to place each filter output for each ID onto sh_3, without overwriting previous placed values/rows.
Using your previously-posted sample workbook this works for me:
Sub document_link_extract()
'Define data source
Dim GDL_Data As Worksheet 'Datasheet holding Docs links
Dim LOB_Doc As Worksheet 'Docs to filter for
Dim Doc_Output_sh As Worksheet 'Seed Template - curated document list
Dim Doc_ID_List() As String, v, rngIds As Range
Dim arrVals, arrSearch, dict, rwV As Long, rwS As Long, srch
Set GDL_Data = ThisWorkbook.Sheets("Sheet2") 'DataSheet
Set LOB_Doc = ThisWorkbook.Sheets("Sheet1") 'Filter Criteria Sheet
Set Output_sht = ThisWorkbook.Sheets("Sheet3") 'Output for' Look 1/2 - URL Check & PDF Extract
Output_sht.UsedRange.Clear
'get array of search terms
With LOB_Doc
arrSearch = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
'get array of data column values
With GDL_Data
arrVals = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
Set dict = CreateObject("scripting.dictionary")
'loop over each search term
For rwS = 1 To UBound(arrSearch, 1)
srch = "*" & arrSearch(rwS, 1) & "*" '<< search term with wildcards
'loop over each value
For rwV = 1 To UBound(arrVals, 1)
v = arrVals(rwV, 1)
'if value matches search term then add to dictionary
If v Like srch Then dict(v) = True
Next rwV
Next rwS
GDL_Data.AutoFilterMode = False 'if there is any filter, remove it
'filter using the dictionary keys array
GDL_Data.UsedRange.AutoFilter 1, dict.keys, xlFilterValues
GDL_Data.UsedRange.Copy Output_sht.Range("A1")
GDL_Data.AutoFilterMode = False
End Sub
I'm using the vlookup function in my vba code, but it's taking too much time to run when I have more then 100k rows of data:
Sub getType()
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error Resume Next
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim Row As Long
Dim Clm As Long
Set ws = Sheets("P")
LastRow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Table1 = Sheet2.Range("A2:A" & LastRow1)
Set ws = Sheets("CRI")
LastRow2 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Table2 = CRI.Range("A2:D" & LastRow2)
Row = Sheet2.Range("J2").Row
Clm = Sheet2.Range("J2").Column
For Each cl In Table1
Sheet2.Cells(Row, Clm).Value = Application.WorksheetFunction.VLookup(cl, Table2, 4, False)
Row = Row + 1
Next cl
Calculate
Reading some topics here I checked that it's possible to speed up by using dictionary, but I didn't understand the concepts correctly to implement the solution on my code.
Also, there is no duplicate data on table2, but table1 contains duplicate values.
Could anyone please help me convert vlookup to dictionary and if possible reference some videos tutorials so I can learn the concept?
This is good explanation on the use of a dictionary:
https://excelmacromastery.com/vba-dictionary/
Don't forget to add “Microsoft Scripting Runtime” as a reference to your project.
I ran a few tests to check performance. For a million rows of data I had the following results:
VLookup: 27.93 seconds
Dictionary: 20.83 seconds
Dictionary and array: 2.32 seconds
Have you considered using a dictionary and an array to store the values before writing them to the sheet? This link will provide you with some good information:
https://excelmacromastery.com/excel-vba-array/#How_To_Make_Your_Macros_Run_at_Super_Speed
Consider the following (I tried to leave as much of your original code as possible):
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error GoTo Handler
Dim ws As Worksheet
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim i As Long
Dim Table1 As Range
Dim Table2 As Range
Dim cl As Range
Dim r As Range
Dim targetRange As Range
Dim valuesArray As Variant
Dim dict As New Scripting.Dictionary
Dim timeStart As Double
Dim timeInterval As Double
'start a timer to measure performance
timeStart = Timer()
'Get the column of data to search through
Set ws = Sheets("P")
LastRow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set Table1 = ws.Range("A2:A" & LastRow1)
'Get the table of values to search for
Set ws = Sheets("CRI")
LastRow2 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set Table2 = ws.Range("A2:D" & LastRow2)
'Add the contents of the table you are searching to the dictionary:
'For each row in the table
For Each r In Table2.Rows
'Add the key and associated value for that key
dict.Add r.Cells(1, 1).Value, r.Cells(1, 4).Value
Next r
'Dimension an array to fit all of your values
ReDim valuesArray(1 To LastRow1, 1 To 1)
'Use i to allocate the data to the array
i = 1
For Each cl In Table1
'Set the value of the array element to the value returned by the dictionary
valuesArray(i, 1) = dict(cl.Value)
i = i + 1
Next cl
'Set a target range to put your values in and make it the right size to fit your array
Set targetRange = Worksheets("Target").Range("J2").Resize(UBound(valuesArray, 1) - 1)
'Put the array in the target range
targetRange = valuesArray
'Check how much time it took
timeInterval = Timer() - timeStart
Debug.Print timeInterval
Application.ScreenUpdating = True
Hope this helps.
Here's some test code to show why I suggested running your VLOOKUP against the range on the worksheet instead of against the array (which is what you got by not using Set Table = ... )
Worksheet formulas like vlookup are optimised for worksheets, not for arrays.
The lookup against the sheet is about 130x faster than the array lookup.
Sub Tester()
Const NUMR As Long = 100000
Dim r As Long, arr, t, m, rng
'Fill some dummy data if not already there
If Sheet1.Range("A1") = "" Then
For r = 1 To NUMR
Sheet1.Cells(r, 1).Resize(1, 4).Value = _
Array(CLng(Rnd * NUMR), "A", "B", r)
Next r
End If
Set rng = Sheet1.Range("A1").CurrentRegion
arr = rng.Value
'Vlookup against array
t = Timer
For r = 1 To 100
m = Application.VLookup(r, arr, 4, False)
Next r
Debug.Print Timer - t '>> 10.28
'Vlookup against worksheet Range
t = Timer
For r = 1 To 100
m = Application.VLookup(r, rng, 4, False)
Next r
Debug.Print Timer - t '>> 0.078
End Sub
I tried to get the unique value of each column in the range "RD" and display them in single column. I need to create an object ("scripting.Dictionary") where there are just as many as the number of columns in Range "RD". I tried this code but it resulted in "Run time error 13".
Private Sub CommandButton1_Click()
Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")
For k = 0 To JK + 1
d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
c = Range("RD").Columns(k + 1)
If d.Exists(k) Then
d.Item(k) = d.Item(k) + 1 'increment
Else
d.Item(k) = 1 'set as 1st occurence
End If
For i = 1 To UBound(c, 1)
d.Item(k)(c(i, 1)) = 1
Next i
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k
End Sub
I'm adding some code below to help loop through a list, looking for unique values, and adding them to a new column. In my example, I enclose the entire functionality into a single loop for efficiency. I'm also adding the unique values to a new column in Sheet2 starting with cell A1.
Let me know if you need any additional help.
EDITED CODE BASED ON A MISUNDERSTANDING:
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim oCol As Range
Dim cel As Range
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each oCol In rngToScrub.Columns
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In oCol.Cells
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
Set oDict = Nothing
Next oCol
End Sub
Old code: Misunderstood requirements
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each cel In rngToScrub
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
End Sub