I am working on an Excel VBA code for a spreadsheet. The aim of the following code is to count how many times the voucher number in this row appears in the whole column G. As the raw data has more than 60,000 rows, the following code will take more than 2 mins to finish.
Worksheets("Raw Data").Range("AP2:AP" & lastrow).Formula = "=IF(AO2=""MATCHED"",""MATCHED"",IF((COUNTIF(AQ_u,G2))>0,""MATCHED"",""NOT MATCHED""))"
I also tried an alternatvie way, which basically is also a CountIF function:
Dim cel, rng As Range
Set rng = Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
For Each cel In Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
If Application.WorksheetFunction.CountIf(rng, cel.Offset(0, -36).Value) > 0 Then
cel.Offset(0, -1).Value = 1
End If
Next cel
Both of the codes above take a long time to finish, so I am wondering whether there is a way to make the code more efficient? Many thanks.
Try the code bellow (it uses an array and a dictionary)
For dictionaries late binding is slow: CreateObject("Scripting.Dictionary")
Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime
Option Explicit
Public Sub CountVouchers()
Const G As Long = 7 'col G
Const AQ As Long = 43 'col AQ
Dim ws As Worksheet: Dim i As Long: Dim d As Dictionary
Dim arr As Variant: Dim lr As Long: Dim t As Double
t = Timer: Set d = New Dictionary
Set ws = ThisWorkbook.Worksheets("Raw Data")
lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
ws.Columns("AP").Clear
arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) 'Range to Array
For i = 2 To lr
If Len(Trim(arr(i, AQ))) > 0 Then d(CStr(arr(i, AQ))) = 1
Next
For i = 2 To lr
If d.Exists(CStr(arr(i, G))) Then arr(i, AQ - 1) = 1 'Count
Next
ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr 'Array back to Range
Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"
'Rows: 100,001, Time: 1.773 sec
End Sub
If you want to see total number of occurrences for each voucher:
Public Sub CountVoucherOccurrences()
Const G As Long = 7
Const AQ As Long = 43
Dim ws As Worksheet: Dim i As Long: Dim d As Dictionary
Dim arr As Variant: Dim lr As Long: Dim t As Double
t = Timer: Set d = New Dictionary
Set ws = ThisWorkbook.Worksheets("Raw Data")
lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
ws.Columns("AP").Clear
arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ))
For i = 2 To lr
d(arr(i, AQ)) = IIf(Not d.Exists(arr(i, AQ)), 1, d(arr(i, AQ)) + 1)
Next
For i = 2 To lr
If d.Exists(arr(i, G)) Then arr(i, AQ - 1) = d(arr(i, AQ))
Next
ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr
Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"
'Rows: 100,001, Time: 1.781 sec
End Sub
Related
I'm trying to run a macro but now it keeps freezing excel.
It runs with 10 cells, but when the macro is applied to almost two hundred, it freezes and crashes.
Sub eancheck()
Dim s1 As Worksheet, s2 As Worksheet
Dim Msg As String
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet3")
Dim lr1 As Long, lr2 As Long
lr1 = s1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = s2.Range("a" & Rows.Count).End(xlUp).Row
Dim i As Long, j As Long
Application.ScreenUpdating = False
For i = 2 To lr1
s1.Cells(i, "D").Interior.ColorIndex = 0
For j = 2 To lr2
If s2.Range("A" & j) = s1.Range("D" & i) Then
's1.Range("D" & i) = s2.Range("B" & j)
s1.Cells(i, "D").Interior.ColorIndex = 3
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
I'm having problems with other macros too, and i think is because of the size of the range. How can i fix it?
Note: The macro runs when searching 10 values in a sheet with two columns with almost 200.000 values each, but when instead of 10 is 200, crashes.
Use conditional formatting in your sheet1 with formula and apply it on range like D2:D5000 or whatever is suitable.
=COUNTIF(Sheet3!A2,D2)>0
Try Declaring all the required variables separately.
Use Application.ScreenUpdating = false in the beginning of the program.
Your first line of for loop can be outside the for loop as well.
Use Collections to make the checks.
For Example, I started with data like this on Sheet 1 Col A,
And data like this on Sheet 3 Col A.
And this is the Macro that I have,
Sub eancheck()
Application.ScreenUpdating = False
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim Msg As String
Dim lr1 As Long
Dim lr2 As Long
Dim i As Long
Dim j As Long
Dim Sheet1ObjectsCol As Collection
Dim Sheet3ObjectsCol As Collection
Dim IdentifierCol As Collection
Set s1 = ThisWorkbook.Sheets("Sheet1")
Set s2 = ThisWorkbook.Sheets("Sheet3")
Set Sheet1ObjectsCol = New Collection
Set Sheet3ObjectsCol = New Collection
Set IdentifierCol = New Collection
lr1 = s1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = s2.Range("a" & Rows.Count).End(xlUp).Row
s1.Range("D2" & ":" & "D" & lr1).Interior.ColorIndex = 0
'Load the collections
For i = 2 To lr1
Sheet1ObjectsCol.Add s1.Range("A" & i).Value
Next
'Load the collections
On Error Resume Next
For i = 2 To lr2
Sheet3ObjectsCol.Add s2.Range("A" & i).Value, CStr(s2.Range("A" & i).Value)
Next
'Create the Identifier Collection
For i = 1 To Sheet1ObjectsCol.Count
ColorValReq = 0
For j = 1 To Sheet3ObjectsCol.Count
If Sheet1ObjectsCol(i) = Sheet3ObjectsCol(j) Then
ColorValReq = 3
GoTo Idenitified
End If
Next
Idenitified:
IdentifierCol.Add ColorValReq
Next
For i = 1 To IdentifierCol.Count
j = i + 1
If IdentifierCol(i) = 3 then
s1.Range("D" & j).Interior.ColorIndex = IdentifierCol(i)
End if
Next
Application.ScreenUpdating = True
End Sub
And this is the output I got,
Hi everyone hope you are doing well. I have a code that depends on a concatenate process to be used later. The piece of code where I make the concatenate is the following:
i=2
Do while ws.cells(i,2) <> 0
ws.cells(i,1) = "=concatenate(C" & i & ", D" & i & ")"
i = i + 1
Loop
The problem is if I have a big sample, it takes too much time to complete. Do you guys know any way to make it better and faster? Thanks in advance
Difference between Formulas and Arrays:
Formula - Total Rows: 1,048,576, Time: 2.414 sec
Arrays - Total Rows: 1,048,576, Time: 3.758 sec
Option Explicit
Public Sub JoinCDinA1()
Dim ws As Worksheet, lr As Long, tr As String, t As Double
t = Timer
Set ws = Sheet1
lr = ws.UsedRange.Rows.Count
With ws.Range("A2:A" & ws.UsedRange.Rows.Count)
.Formula = "= C2 & D2"
.Value2 = .Value2
End With
tr = "Formula - Total Rows: " & Format(lr, "#,###,###")
Debug.Print tr & ", Time: " & Format(Timer - t, "0.000") & " sec"
End Sub
Public Sub JoinCDinA2()
Dim ws As Worksheet, ur1 As Variant, ur2 As Variant, r As Long, lr As Long
Dim tr As String, t As Double
t = Timer
Set ws = Sheet1
lr = ws.UsedRange.Rows.Count
ur1 = ws.Range(ws.Cells(2, 1), ws.Cells(lr, 1))
ur2 = ws.Range(ws.Cells(2, 3), ws.Cells(lr, 4))
For r = 1 To lr - 1
ur1(r, 1) = ur2(r, 1) & ur2(r, 2)
Next
ws.Range(ws.Cells(2, 1), ws.Cells(lr, 1)) = ur1
tr = "Arrays - Total Rows: " & Format(lr, "#,###,###")
Debug.Print tr & ", Time: " & Format(Timer - t, "0.000") & " sec"
End Sub
There are few ways to assign all at once without loop. For example:
ws.Range("A2:A" & ws.UsedRange.Rows.Count - 1).Formula = "= C2 & D2"
Bulk loading an array, processing said array then dropping the results back to the worksheet en masse is almost always appreciably faster than a loop.
dim i as long, vals as variant
with worksheets("sheet1")
vals = .range(.cells(2, "C"), .cells(.rows.count, "B").end(xlup).offset(0, 2))
for i=lbound(vals, 1) to ubound(vals, 1)
vals(i, 1) = join(array(vals(i, 1), vals(i, 2)), vbnullstring)
next i
redim preserve vals(lbound(vals, 1) to ubound(vals, 1), 1 to 1)
.cells(2, "A").resize(ubound(vals, 1), 1) = vals
end with
I have two spreadsheets (wb and wbtemp); both have a column for location and a column for feature type. In VBA, I want to find all of the rows on the second sheet where the two columns are the same as the two columns on a row in the first sheet and get a list or a range made up of the row numbers/indices.
I then want to use this range to pull out values from a different column and find the highest object in it, but I think I will probably be able to do that if I can get this range sorted.
Dim wb As Workbook
Dim ws As Worksheet
Dim Features() As Variant
Dim Activity() As Variant
Dim Benthic As Variant
Dim wbtemp As Workbook
Dim BenSenFeatures() As Variant
Dim BenSenActivity() As Variant
Dim LR As Long
Dim LC As Long
Dim r As Long
Dim c As Long
Dim WhatToFind1 As Variant
Dim WhatToFind2 As Variant
Dim rngFound1 As Range
Dim rngFound2 As Range
Dim rng1 As Variant
Dim rng2 As Variant
Dim rngFound As Range
Dim iLoop As Long
Dim colFound As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Features = ws.Range("B:C").Value
Activity = ws.Rows(1).Value
Benthic = InputBox("Filename goes here...")
Set wbtemp = Workbooks.Open(Benthic, True, True)
With wbtemp
BenSenFeatures = .Sheets(1).Range("A:B").Value
BenSenActivity = .Sheets(1).Rows(1).Value
End With
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For r = 3 To LR
If Not IsEmpty(Features(r, 2)) Then
If IsInArray(Features(r, 2), BenSenFeatures, 2) Then
'If WorksheetFunction.Match(Features(r, 2), BenSenFeatures(0, 2), 0) Then <---I tried to use the arrays originally
WhatToFind1 = Features(r, 1)
WhatToFind2 = Features(r, 2)
Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells(wbtemp.Sheets(1).Columns(1).Cells.Count)
Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells(wbtemp.Sheets(1).Columns(2).Cells.Count)
For iLoop = 1 To WorksheetFunction.CountIf(wbtemp.Sheets(1).Columns(1), WhatToFind1)
Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells.Find(WhatToFind1, After:=rngFound1)
rng1(iLoop) = rngFound1.Row
'WorksheetFunction.Index(wbtemp.Sheets(1).Range("A:B").Value,_
WorksheetFunction.Match(WhatToFind1 & WhatToFind2,_
wbtemp.Sheets(1).Columns(1) & wbtemp.Sheets(1).Columns(2),_
0), 1) <---originally tried to use match to search for the multiple criteria but couldn't find a way to create a list of indices
Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells.Find(WhatToFind2, After:=rngFound2)
rng2(iLoop) = rngFound2.Row
Next iLoop
For Each cell In rng1
If Not Application.CountIf(rng2, cell.Value) = 0 Then
rngFound.Cells(Cells(Rows.Count, 1).End(xlUp) + 1) = cell.Value
End If
Next
I originally tried to use .Match to find the multiple criteria, but I couldn't figure out how to create a range of indices from it. Then I tried using .Find to create two list of indices but I can't figure out how to get that to work. I keep getting
Type Mismatch
errors.
I realise this sounds confusing, so let me know if anything needs clarifying.
Something like this should work for you. I tried to comment the code for clarity.
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim rData As Range
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
Dim rTempData As Range
Dim aData() As Variant
Dim aTempData() As Variant
Dim aResults() As Variant
Dim lNumResults As Long
Dim DataIndex As Long, TempIndex As Long, ResultIndex As Long, j As Long
Dim sCritRange1 As String, sCritRange2 As String
Dim sCriteria1 As String, sCriteria2 As String
Set wb = ActiveWorkbook
'Adjust these two as necessary
Set ws = wb.Sheets(1)
Set rData = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp))
'Select wbTemp file
On Error Resume Next
Set wbTemp = Workbooks.Open(Application.GetOpenFilename("Excel Files, *.xls*"))
On Error GoTo 0
If wbTemp Is Nothing Then Exit Sub 'Pressed cancel
'Adjust these two as necessary
Set wsTemp = wbTemp.Sheets(1)
Set rTempData = wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData.Address(external:=True)
sCriteria2 = rData.Offset(, 1).Address(external:=True)
lNumResults = Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))")
If lNumResults = 0 Then Exit Sub 'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData.Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value
'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)
'Find where both criteria matches
If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
'Match found, add to results and collect the row index
ResultIndex = ResultIndex + 1
aResults(ResultIndex, 1) = aData(DataIndex, 1)
aResults(ResultIndex, 2) = aData(DataIndex, 2)
aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1 'This is the row index from wsTemp of the found match
End If
Next TempIndex
Next DataIndex
'Row index results gathered
'Do what you want with the results
'In this example it is just providing msgboxes displaying the results
For ResultIndex = LBound(aResults, 1) To UBound(aResults, 1)
MsgBox "Location: " & aResults(ResultIndex, 1) & Chr(10) & _
"Feature: " & aResults(ResultIndex, 2) & Chr(10) & _
"RowIndex: " & aResults(ResultIndex, 3)
Next ResultIndex
'Close wbTemp
wbTemp.Close
End Sub
I made some minor modifications to tigeravatar's answer to get it to work with my data:
Mainly creating a loop which cycled through each row in wb so that the criteria used with CountIfs was a single value and not a range of values.
I swapped the Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))") for Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
I would like to thank tigeravatar for their help.
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For r = 3 To LR
sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData(r, 1).Address(external:=True)
sCriteria2 = rData(r, 1).Offset(, 1).Address(external:=True)
lNumResults = Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
If lNumResults = 0 Then Exit Sub 'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData(r, 1).Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value
'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)
'Find where both criteria matches
If Not IsEmpty(aTempData(TempIndex, 1)) Then
If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
'Match found, add to results and collect the row index
ResultIndex = ResultIndex + 1
aResults(ResultIndex, 1) = aData(DataIndex, 1)
aResults(ResultIndex, 2) = aData(DataIndex, 2)
aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1 'This is the row index from wsTemp of the found match
End If
End If
Next TempIndex
Next DataIndex
Next r
I am looking to do a vlookup via a dictionary in a VBA Macro. I have seen a few examples around the internet but they are mostly very specific and I am hoping to get assistance with more "bare bones" code. I will use a simple example of what I would like to achieve:
Lookup Value to be each cell within a dynamic range starting in cell B2 on the "Orders" Worksheet (bottom row varies)
Table Array to be on a dynamic range starting in cell E2 and extending to column L on the "Report" Worksheet (Bottom row varies)
Column Index Number is to be 8 (Column L)
Range Lookup is to be False
My current code is below:
Sub DictionaryVLookup()
Dim x, y, z(1 To 10)
Dim i As Long
Dim dict As Object
Dim LastRow As Long
LastRow = Worksheets("Report").Range("B" & Rows.Count).End(xlUp).Row
x = Sheets("Orders").Range("B2:B" & LastRow).Value
y = Sheets("Report").Range("E2:E" & LastRow).Value 'looks up to this range
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x(i, 1)
Next i
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
z(i) = y(i, 1)
Else
z(i) = "NA"
End If
Next i
Worksheets("Orders").Range("Z2:Z" & LastRow).Value = Application.Transpose(z) 'this is where the values are placed
End Sub
I seem to be missing the "lookup" portion, currently this runs without error and simple places the values which are "found" by the lookup, but I don't know how to have the returned value be offset (want to return column L in this example).
Also I did some "Frankenstein" work with this code - so I am not sure why this is present:
Dim x, y, z(1 To 10)
the (1 to 10) I will want to be dynamic I would guess.
This is my first attempt at using a dictionary in this fashion - Hoping to get a basic understanding through this simple example which I can then implement into more involved situations.
I know there are other methods to do what I am describing, but looking to learn specifically about dictionaries.
Thanks in advance for any assistance !
Something like this:
Sub DictionaryVLookup()
Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRow As Long, shtOrders As Worksheet, shtReport As Worksheet
Set shtOrders = Worksheets("Orders")
Set shtReport = Worksheets("Report")
Set dict = CreateObject("Scripting.Dictionary")
'get the lookup dictionary from Report
With shtReport
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
x = .Range("E2:E" & LastRow).Value
x2 = .Range("L2:L" & LastRow).Value
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x2(i, 1)
Next i
End With
'map the values
With shtOrders
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
y = .Range("B2:B" & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range("Z2:Z" & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
Generalized #Tim Williams excellent example to have no Hard coded ranges in main sub for helping following users.
'In sheet Phones lookup col F at LogFileSh sheet col CE,CF and return
'the results in col D sheet Phones. Row of F+D is 2 and row CE+CF is 2.
Sub RunDictionaryVLookup()
Call GeneralDictionaryVLookup(Phones, LogFileSh, "F", "CE", "CF", "D", 2, 2)
End Sub
Sub GeneralDictionaryVLookup(ByVal shtResault As Worksheet, ByVal shtsource As Worksheet, _
ByVal colLOOKUP As String, ByVal colDicLookup As String, ByVal colDicResault As String, ByVal colRESULT As String, _
ByVal rowSource As Long, ByVal rowResult As Long)
Dim x As Variant, x2 As Variant, y As Variant, y2() As Variant
Dim i As Long
Dim dict As Object
Dim LastRow As Long
Set dict = CreateObject("Scripting.Dictionary")
'get the lookup dictionary
With shtsource
LastRow = .Range(colDicLookup & Rows.Count).End(xlUp).row
x = .Range(colDicLookup & rowSource & ":" & colDicLookup & LastRow).Value
x2 = .Range(colDicResault & rowSource & ":" & colDicResault & LastRow).Value
For i = 1 To UBound(x, 1)
dict.item(x(i, 1)) = x2(i, 1)
Debug.Print dict.item(x(i, 1))
Next i
End With
'map the values
With shtResault
LastRow = .Range(colLOOKUP & Rows.Count).End(xlUp).row
y = .Range(colLOOKUP & rowResult & ":" & colLOOKUP & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.Exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range(colRESULT & rowResult & ":" & colRESULT & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
How do i loop through one million rows in vba to find the instr numbers then trying to copy it to different sheet. I have a two different worksheet, one of them holding one million strings and the one 150. And im looping through to finding instr then pasting into another sheets.My code is working slow also how do i make it faster.
Sub zym()
Dim x As Long, lastrow As Long, lastrowx As Long, i As Long, ii As Long
Dim ws As Worksheet, wb As Workbook, ws2 As Worksheet, wb2 As Workbook
Dim b As String, ws3 As Worksheet, ym As Long, lastrowy As Long, iii As Long
Dim j As Integer
Dim data As Variant
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
j = 1
Dim sheet1array As Variant, sheet2array As Variant
T1 = GetTickCount
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
lastrowx = ws2.Range("A" & Rows.Count).End(xlUp).Row
ReDim sheet1array(1 To lastrow)
ReDim sheet2array(1 To lastrowx)
data = Range("A1:Z1000000").Value
For i = LBound(sheet1array, 1) To UBound(sheet1array, 1)
b = "-" & ws.Range("A" & i).Value & "-"
For ii = LBound(sheet2array, 1) To UBound(sheet2array, 1)
If data(i, ii) = InStr(1, ws2.Cells(ii, 1), b) Then
ws3.Range("A" & j) = ws2.Range("A" & ii)
j = j + 1
End If
Next ii
Next i
Debug.Print "Array Time = " & (GetTickCount - T1) / 1000#
Debug.Print "Array Count = " & Format(n, "#,###")
End Sub
Tested with 0.5M entries on sheet1 and 150 on sheet2:
Sub tym()
Dim ws1 As Worksheet, wb As Workbook, ws2 As Worksheet
Dim b, c As Range, rngNums As Range, rngText As Range
Dim dNums, dText, rN As Long, rT As Long, t, m
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
Set c = wb.Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Set rngNums = ws1.Range(ws1.Range("A1"), ws1.Cells(Rows.Count, 1).End(xlUp))
dNums = rngNums.Value
Set rngText = ws2.Range(ws2.Range("A1"), ws2.Cells(Rows.Count, 1).End(xlUp))
dText = rngText.Value
t = Timer
'Method1: use if only one possible match
' (if any number from sheet1 can only appear once on sheet2)
' and sheet2 values are all of format 'text-number-text'
For rT = 1 To UBound(dText, 1)
b = CLng(Split(dText(rT, 1), "-")(1))
m = Application.Match(b, rngNums, 0)
If Not IsError(m) Then
c.Value = dText(rT, 1)
Set c = c.Offset(1, 0)
End If
Next rT
Debug.Print "Method 1", Timer - t
t = Timer
'Method2: use this if conditions above are not met...
For rN = 1 To UBound(dNums, 1)
b = "*-" & dNums(rN, 1) & "-*"
For rT = 1 To UBound(dText, 1)
If InStr(1, b, dText(rT, 1)) > 0 Then
c.Value = dText(rT, 1)
Set c = c.Offset(1, 0)
End If
Next rT
Next rN
Debug.Print "Method 2", Timer - t
End Sub
Method1: ~0.5 sec
Method2: ~17 sec
the find method of a range is faster: https://msdn.microsoft.com/en-us/library/office/ff839746.aspx?f=255&MSPPError=-2147217396
Maybey you could give this a try?
This code expects to find headers for column A on both sheets(1 and 2)
It removes duplicates from column A on Sheet1
It Autofilters Sheet2 for each item on Sheet1
Copies visible rows from Sheet2 to Sheet3
Option Explicit
Public Sub findValues()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, vr As Range
Dim ur1 As Range, ur2 As Range, ur3 As Range, thisRow As Long
Dim i As Byte, ur As Range, itms As Variant, itm As Variant
Set ws1 = Worksheets("Sheet1"): Set ur1 = ws1.UsedRange
Set ws2 = Worksheets("Sheet2"): Set ur2 = ws2.UsedRange
Set ws3 = Worksheets("Sheet3"): Set ur3 = ws3.UsedRange
ur1.RemoveDuplicates Columns:=1, Header:=xlNo
itms = ur1.Columns(1)
If ws2.AutoFilter Is Nothing Then ur2.AutoFilter
Set ur = ur2.Offset(1, 0).Resize(ur2.Rows.Count - 1, ur2.Columns.Count)
Application.ScreenUpdating = False
For Each itm In itms
If i > 0 Then
ur2.Columns(1).AutoFilter Field:=1, Criteria1:="*" & itm & "*"
Set vr = ur2.SpecialCells(xlCellTypeVisible)
If vr.Count > ur2.Columns.Count Then
ur.Copy ur3.Cells(ur3.Rows.Count + 1, ur2.Column)
Set ur3 = ws3.UsedRange
End If
End If
i = i + 1
Next
ws3.Cells(1).EntireRow.Delete
ur2.AutoFilter
Application.ScreenUpdating = True
End Sub