excel - How do i loop through using instr value in 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