Question

如何遍历vba中的一百万行以查找instr数字，然后尝试将其复制到不同的工作表。我有两个不同的工作表，其中一个包含一百万个字符串，另一个包含150个。然后我循环查找instr然后粘贴到另一个工作表。我的代码工作缓慢，如何让它更快。

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/en-us/library/office/ff839746.aspx?f=255&MSPPError=-2147217396

Maybey你可以尝试一下吗？

Answer 3

此代码需要在两个工作表（1和2）上找到A列的标题

它会从Sheet1
对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

我如何循环使用vba中的instr值

3 个答案: