How do i loop through using instr value in vba - vba

Question

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

Answer 1

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

Answer 2

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?

Answer 3

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