如何在VBA中循环使用Instr值

Question

我如何在VBA中遍历一百万行以找到指令编号，然后尝试将其复制到其他工作表中。 我有两个不同的工作表，其中一个包含一百万个字符串，一个包含150个。我反复遍历找到instr，然后粘贴到另一张sheets。我的代码运行缓慢，我又如何使其更快。

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

使用sheet1上的0.5M条目和sheet2上的150个条目进行了测试：

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

• 方法1：〜0.5秒
• 方法2：〜17秒

Answer 2

范围的查找方法更快： https : //msdn.microsoft.com/zh-cn/library/office/ff839746.aspx?f=255&MSPPError=-2147217396

也许您可以尝试一下？

Answer 3

该代码希望在两个工作表（1和2）上都找到A列的标题

• 它从Sheet1的A列中删除重复项
• 它为Sheet1上的每个项目自动过滤Sheet2
• 将可见行从Sheet2复制到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