I have a code, that grabs data from a column of a file, and puts it into an array.
now, I want to go through this array and delete duplicates but I can't make it go through... any ideas?
this is the code, and the array is at the end:
Dim i As Long
Dim searchItem As Variant
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
Next i
End With
s_wbk.Close
searchItem = Split(strSearch, ",") '*NEED TO REMOVE DUPLICATES
Remove the duplicates during the string construction by testing for prior existence with InStr function.
If Not IsEmpty(Cells(i, 1).Value) And _
Not InStr(1, strSearch, Cells(i, 1).Value & ",", vbTextCompare) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
You should also remove the last trailing comma before splitting.
Next i
strSearch = Left(strSearch, Len(strSearch) - 1)
Finally, if you had added the values into a Scripting.Dictionary object (which comes with its own unique primary key index), you would have a unique set of keys in an array already built for you.
This worked for me:
Function removeDuplicates(ByVal myArray As Variant) As Variant
Dim d As Object
Dim v As Variant 'Value for function
Dim outputArray() As Variant
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(myArray) To UBound(myArray)
d(myArray(i)) = 1
Next i
i = 0
For Each v In d.Keys()
ReDim Preserve outputArray(0 To i)
outputArray(i) = v
i = i + 1
Next v
removeDuplicates = outputArray
End Function
Hope it helps
Easiest way would be to duplicate the sheet you take your input from and use built-in function to get rid of the duplicates, take a look at this :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
If Not IsEmpty(.Cells(i, 1)) Then
strSearch = strSearch & "," & .Cells(i, 1).Value
End If
Next i
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
searchItem = Split(strSearch, ",") 'NO MORE DUPLICATES ;)
Or even faster (as you won't have empty cells in the range after the RemoveDuplicates) :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
'NO MORE DUPLICATES and FASTER ARRAY FILL ;)
searchItem = .Range(.Range("A1"), .Range("A" & .Rows.count).End(xlUp)).Value
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
Usually I use a dictionary object to check for duplicates, or use it itself. A dictionary is an object that references unique keys to values. Since the keys have to be unique it is quite usable for collecting unique values. Maybe it is not the most memory efficient way and probaby a little abues of the object, but it works quite fine.
You have to dim an object and set it to a dictionary, collect the data, after checking it doesn't already exist and then loop through the dictionary to collect the values.
Dim i As Long
Dim searchItem As Variant, var as variant
dim dicUniques as object
set dicUniques = CreateObject("Scripting.Dictionary")
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
if dicUniques.exists(cells(i,1).value) = false then
dicUniques.add cells(i,1).value, cells(i,1).value
end if
End If
Next i
End With
s_wbk.Close
for each var in dicUniques.keys
strSearch = strSearch & ", " & var
next var
searchItem = Split(strSearch, ",")
That's the quick and dirty solution. Since the keys are unique you could probably use them by themselves, without putting them together in the string first.
By the way: First of all, you shoudl specify which cells you use. Sometimes you start the macro form another worksheet and then it will use the cells there, if no parent worksheet is given for the cells object.
Second, it is important to specify you want to use the cells value for the dictionary, since a dictionary object can contain anything. So if you don't use cells(x,y).value the object will contain the cell itself.
edit: Corrected typo in the routine.
Unique Column To Array
Option Explicit
Sub removeDuplicates()
Const strFile = "...\Desktop\xl files min\src.xlsm"
Const SheetName As String = "Sheet1"
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const FirstRow As Long = 2
Dim s_wbk As Workbook
Dim SourceArray, WorkArray, searchItem
Set s_wbk = Workbooks.Open(strFile)
SourceArray = copyColumnToArray(s_wbk.Worksheets(SheetName), _
FirstRow, SourceColumn)
s_wbk.Close
If Not IsArray(SourceArray) Then Exit Sub
WorkArray = Application.Transpose(SourceArray) ' only up to 65536 elements.
searchItem = getUniqueArray(WorkArray)
End Sub
Function copyColumnToArray(SourceSheet As Worksheet, _
FirstRowNumber As Long, ColumnNumberLetter As Variant) As Variant
Dim rng As Range
Dim LastRowNumber As Long
Set rng = SourceSheet.Columns(ColumnNumberLetter).Find(What:="*", _
LookIn:=xlFormulas, Searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Function
Set rng = SourceSheet.Range(SourceSheet _
.Cells(FirstRowNumber, ColumnNumberLetter), rng)
If Not rng Is Nothing Then copyColumnToArray = rng
End Function
Function getUniqueArray(SourceArray As Variant, _
Optional Transpose65536 As Boolean = False) As Variant
' Either Late Binding ...
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' ... or Early Binding:
' VBE > Tools > References > Microsoft Scripting Runtime
'Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary
Dim i As Long
For i = LBound(SourceArray) To UBound(SourceArray)
If SourceArray(i) <> Empty Then
dict(SourceArray(i)) = Empty
End If
Next i
' Normal: Horizontal (Row)
If Not Transpose65536 Then getUniqueArray = dict.Keys: GoTo exitProcedure
' Transposed: Vertical (Column)
If dict.Count <= 65536 Then _
getUniqueArray = Application.Transpose(dict.Keys): GoTo exitProcedure
' Transpose only supports up to 65536 items (elements).
MsgBox "Source Array contains '" & dict.Count & "' unique values." _
& "Transpose only supports up to 65536 items (elements).", vbCritical, _
"Custom Error Message: Too Many Elements"
exitProcedure:
End Function
Related
I have a table which looks like this:
I wrote code which gives output like this:
The goal is a results table which does the following:
Count number of times "old" status appears
Count numer of times "new" status appears
Get all the (unique) old groups in one cell
Get all the (unique) new groups in one cell
The following code worked on one computer but not on another (both Windows, 64bit):
Sub TableSummary()
Dim sht As Worksheet
Dim i As Integer
Dim tbl As ListObject
Dim new_tbl As ListObject, old_tbl As ListObject
Dim new_array As Variant, old_array As Variant
'2. Disable Screen Updating - stop screen flickering and Disable Events to avoid inturupted dialogs / popups
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
Application.DisplayAlerts = True
'4. Add a new summary table to summary worksheet
With ActiveWorkbook
sht.ListObjects.Add(xlSrcRange, sht.UsedRange, , xlYes).Name = "Summary"
sht.ListObjects("Summary").TableStyle = "TableStyleMedium5"
End With
i = 1
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = "Summary" Then
'Define Column Headers of Summary
sht.Cells(1, 4).Resize(1, 4).Value = Array("Nbr of old", "Nbr of new", "Groups old", "Groups new")
i = i + 1
For Each tbl In sht.ListObjects
' Blue table
If tbl.TableStyle = "TableStyleMedium2" Then
sht.Range("D" & i).Value = WorksheetFunction.CountIf(tbl.Range, "old")
sht.Range("E" & i).Value = WorksheetFunction.CountIf(tbl.Range, "new")
Set new_tbl = sht.ListObjects("Summary")
Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(Field:=2, Criteria1:="old")
new_array = Application.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible))) 'This doesn't work on my other machine
sht.Range("F" & i).Value = Join(new_array, ", ") 'works!
'Debug.Print Join(new_array, ", ")
sht.ListObjects("Summary").AutoFilter.ShowAllData
Set new_tbl = sht.ListObjects("Summary")
Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(Field:=2, Criteria1:="new")
new_array = Application.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible))) 'This doesn't work on my other machine
sht.Range("G" & i).Value = Join(new_array, ", ") 'works!
Debug.Print Join(new_array, ", ")
sht.ListObjects("Summary").AutoFilter.ShowAllData
End If
Next
End If
Next
End Sub
Application.Transpose does not work on my second machine.
Here's a different approach using a function to create the list of unique values:
Sub TableSummary()
Const NEW_OLD_COL As Long = 2
Const GROUP_COL As String = "Group"
Const VAL_OLD As String = "old"
Const VAL_NEW As String = "new"
Dim sht As Worksheet, DstSht As Worksheet
Dim i As Integer
Dim tbl As ListObject
Dim new_tbl As ListObject, old_tbl As ListObject
Dim new_array As Variant, old_array As Variant
Set sht = ActiveSheet 'or whatever...
Set DstSht = sht
i = 2
For Each tbl In sht.ListObjects
' Blue table
If tbl.TableStyle = "TableStyleMedium2" Then
With tbl.ListColumns(NEW_OLD_COL)
DstSht.Range("G" & i).Value = WorksheetFunction.CountIf(.DataBodyRange, VAL_OLD)
DstSht.Range("H" & i).Value = WorksheetFunction.CountIf(.DataBodyRange, VAL_NEW)
End With
tbl.Range.AutoFilter Field:=NEW_OLD_COL, Criteria1:="new"
DstSht.Range("I" & i).Value = VisibleUniques(tbl, GROUP_COL)
tbl.Range.AutoFilter
tbl.Range.AutoFilter Field:=NEW_OLD_COL, Criteria1:="old"
DstSht.Range("J" & i).Value = VisibleUniques(tbl, GROUP_COL)
tbl.Range.AutoFilter
i = i + 1
End If
Next
End Sub
'Return a comma-separated list of all unique values in visible cells in
' column `ColName` of listobject `tbl`
Function VisibleUniques(tbl As ListObject, ColName As String) As String
Dim rngVis As Range, dict As Object, c As Range
On Error Resume Next 'ignore error if no visible cells
Set rngVis = tbl.ListColumns(ColName).DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0 'stop ignoring errors
If rngVis Is Nothing Then Exit Function
Set dict = CreateObject("scripting.dictionary")
For Each c In rngVis.Cells
dict(CStr(c.Value)) = True
Next c
VisibleUniques = Join(dict.keys, ", ")
End Function
I have a string of predefined worksheets, that I need to run specific code for. I get a compile error.
The code is set up to copy data from one sheet to another.
How do I do the same for multiple sheets?
When I step through the code sht is showing the MHP60,MHP61,MHP62 and not just MHP60.
I get a subscript out of range error.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim SheetNames() As String
Dim SheetNames2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60, MHP61, MHP62 Trial Balance Values
Dim i, lastcol As Long
Dim tabNames, cell As Range
Dim tabName As String
Dim sht As Variant
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
'SheetNames2 = Strings.Split("MHP60-CYTDprior,MHP61-CYTDprior,MHP62-CYTDprior")
Set wb1 = ActiveWorkbook 'Revenue & Expenditure Summary Workbook
'*****************************Open CYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create CYTD Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Load Column Header Strings & Copy Data
For Each sht In SheetNames
lastcol = wb1.Sheets(sht).Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets(sht).Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets(sht).Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Next sht
MsgBox "CYTD Report Creation Complete", vbOKOnly
Application.ScreenUpdating = True
End Sub
Split by what?
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
Split by comma? Then use the following instead:
SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",")
Alternative
Dim SheetNames() As Variant ' needs to be Variant to work with Array()
SheetNames = Array("MHP60", "MHP61", "MHP62")
This should be quicker as your macro does not need to split the string and has it as array directly.
As shown in the image, I want to first filter by column A for "Yes".
The above image shows after the filter and I want to save each unique "ID" in columns B and put them into an array called myArr. Ideally, myArr = [101, 5137, 97] and I would be able to call each value in the array using myArr(1), myArr(2), myArr(3)
Below is the code I had, but there are 2 problems:
my arr doesn't seem to be an actual array
it doesn't print the correct answers 101, 5137, 97. Instead, it only prints out 101, 5137
With [a1].CurrentRegion
.AutoFilter 1, "Yes"
'first create arr which include duplicated data
arr = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlVisible)
'myArr is an array with unique values
myArr = Application.Unique(arr)
'print out each value of myArr to check if myArr is correct
For Each num In myArr
Debug.Print num
Next num
.AutoFilter
End With
Please give me some ideas on what's wrong with my code above.
Your code is failing because once you apply the filter, the range is no longer contiguous. Your method will only capture a contiguous range.
Because you are setting the Autofilter value from within your routine, lets just check the values inside of an array, and then add the correct values to a dictionary, which will only accept unique values anyways.
Public Sub testUniqueArray()
Dim arrTemp As Variant, key As Variant
Dim dict As Object
Dim i As Long
arrTemp = [a1].CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arrTemp) To UBound(arrTemp)
If arrTemp(i, 1) = "Yes" Then
dict(arrTemp(i, 2)) = 1
End If
Next i
For Each key In dict.Keys
Debug.Print key
Next key
End Sub
Unique Values from Filtered Column to Array
Option Explicit
Sub PrintUniqueValues()
Const CriteriaColumn As Long = 1
Const ValueColumn As Long = 2
Const CriteriaString As String = "Yes"
Dim ws As Worksheet: Set ws = ActiveSheet
' You better improve e.g. by using the worksheet (tab) name...
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
'Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' ... or by using the code name:
'Dim ws As Worksheet: Set ws = Sheet1
Application.ScreenUpdating = False
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
rg.AutoFilter CriteriaColumn, CriteriaString
Dim Arr As Variant: Arr = ArrUniqueFromFilteredColumn(rg, ValueColumn)
ws.AutoFilterMode = False
Application.ScreenUpdating = True
If IsEmpty(Arr) Then Exit Sub
' Either (preferred when dealing with arrays)...
Dim n As Long
For n = LBound(Arr) To UBound(Arr)
Debug.Print Arr(n)
Next n
' ... or:
' Dim Item As Variant
' For Each Item In Arr
' Debug.Print Item
' Next Item
End Sub
Function ArrUniqueFromFilteredColumn( _
ByVal rg As Range, _
ByVal ValueColumn As Long) _
As Variant
If rg Is Nothing Then Exit Function
If ValueColumn < 1 Then Exit Function
If ValueColumn > rg.Columns.Count Then Exit Function
Dim crg As Range
Set crg = rg.Columns(ValueColumn).Resize(rg.Rows.Count - 1).Offset(1)
Dim CellsCount As Long
CellsCount = WorksheetFunction.Subtotal(103, crg) ' 103 - CountA
If CellsCount = 0 Then Exit Function ' no match or only empty cells
'Debug.Print "CellsCount = " & CellsCount
Dim scrg As Range: Set scrg = crg.SpecialCells(xlCellTypeVisible)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' ignore case
Dim cCell As Range
Dim Key As Variant
For Each cCell In scrg.Cells
Key = cCell.Value
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Empty
' The previous line is a short version of:
'If Not dict.Exists(Key) Then dict.Add Key, Empty
End If
End If
Next cCell
If dict.Count = 0 Then Exit Function ' only errors and blanks
'Debug.Print "dict.Count = " & dict.Count
ArrUniqueFromFilteredColumn = dict.Keys
End Function
This question is based on a tip I got in the forum some other day, but since this completely changed the problem I'm creating a new post (it seemed a much better solution than the one I proposed but I'm having some issues).
The rationale of my code is to search up and find entries based on ID in column A (from criteria input in txtbox); if the row matches the search criteria then I want the data from column A to J for that entry to be stored in a dynamic array. All the matching entries will be stored there. This array will be used to display all the relevant entries in a listbox in a userform.
The code is the following:
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
strSearch = txtSearch.Text
Set aCell = sht.Range("A1:A" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
GoTo wfrefvalid
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
Exit Sub
wfrefvalid:
row_number = 0
'clears the listbox so that you have dont have a continuously growing list
lstSearch.Clear
Do
DoEvents
row_number = row_number + 1
ReDim Preserve Arr(item_in_review + 1)
item_in_review = sht.Range("A" & row_number)
If item_in_review = txtSearch.Text Then
Arr = item_in_review.Range("A" & row_number & ":J" & row_number)
End If
Loop Until item_in_review = ""
lstSearch.List = Arr
End Sub
The code isn't giving any debugging-errors, however it's also not doing anything when I press the search button. I think the area where I'm struggling is defining the array, and adding each entry to it as the find-function loops through the table (ie the last 12 or so pieces of code).
ANyone have any tips for adding the data from the search (including the extra columns) to the array?
I think the code would to be like this.
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
Dim rngDB As Range
Dim strAddress As String, n As Long
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rngDB = sht.Range("a1", "a" & lastrrow)
strSearch = txtSearch.Text
With rngDB
Set aCell = .Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
strAddress = aCell.Address
Do
n = n + 1
ReDim Preserve Arr(1 To 10, 1 To n)
For i = 1 To 10
Arr(i, n) = aCell(1, i)
Next i
Set aCell = .FindNext(aCell)
Loop While strAddress <> aCell.Address
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
End With
If n = 1 Then
lstSearch.List = Arr
ElseIf n > 1 Then
lstSearch.List = WorksheetFunction.Transpose(Arr)
End If
End Sub
I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs