Question

我使用此vba代码查找具有100000多行和列的文件。是否可以将此代码重新编写为数组或使用脚本字典？

   Sub vlookuptest()
   Dim i As Long
   On Error Resume Next
   For i = 2 To 1048576
   Sheets("Prices").Cells(i, 6) = Application.WorksheetFunction.VLookup((Worksheets("Prices").Cells(i, 4) & Worksheets("Prices").Cells(i, 3)), Worksheets("Raw Delta").Range("A:O"), 14)
   Next i
   End Sub

先谢谢

这是我的试用代码。这个问题是它没有完美搜索

  Option Explicit

  Sub DRT_GetValues()
  Dim supplierNumber As String
  supplierNumber = ThisWorkbook.Sheets("Main").Range("D5").Value
  Const COL_ARTNUM As Long = 1
  Const COL_ARTDESC As Long = 2
  Const COL_PRICECITY As Long = 9
  Const COL_PRICECOUNTRY As Long = 10
  Const COL_CURRENCY As Long = 11
  Const COL_NETPRICE As Long = 14

  Dim d As Variant, u As Long, r As Long, k, action, w As Long, x As Long, y As Long
  Dim dict As Object
  Dim dOut(), rOut As Long, i As Long
  Dim newRow As Boolean

  Set dict = CreateObject("scripting.dictionary")

  d = Sheets("Raw Delta").Range("A2").CurrentRegion.Offset(2, 0).Value
  u = UBound(d, 1) - 1

  i = 1
  ReDim dOut(1 To u, 1 To 14) 'to hold the output data


  'loop over the input data
  For r = 1 To u


  k = d(r, COL_ARTNUM) & d(r, COL_PRICECOUNTRY) & d(r, COL_PRICECITY) & "-" & supplierNumber

  If Not dict.exists(k) Then
  dOut(i, 6) = d(r, COL_NETPRICE)
  dict.Add k, i
  i = i + 1
  End If
  rOut = dict(k)

  Dim wow As String
  wow = Sheets("Prices").Cells(i, 4) & Sheets("Prices").Cells(i, 3)

  If wow = k Then

  dOut(rOut, 1) = d(r, COL_NETPRICE)

  End If

  Next r



  Sheets("Prices").Range("f2").Resize(u, 14).Value = dOut

  End Sub

Answer 1

使用“原始数据”工作表的A列作为键构建脚本字典对象，将N列的价格（......？）构建为项目

在'价格'工作表上，它从C＆amp;列中获取数据。 D.要从字典中查找价格，它会连接这些值并查找匹配的密钥。

最后，它将找到的值返回到'Price' en masse 的F列。

Sub vlookup_replacement()
    Dim v As Long, vRDA As Variant, vRDN As Variant, vPDC As Variant
    Dim dRDAN As Object

    'Debug.Print Timer
    Set dRDAN = CreateObject("Scripting.Dictionary")

    With Worksheets("Raw Data")
        vRDA = Intersect(.Columns("A:A"), .UsedRange).Value2
        vRDN = Intersect(.Columns("N:N"), .UsedRange).Value2
        For v = LBound(vRDA, 1) To UBound(vRDA, 1)
            If Not dRDAN.exists(vRDA(v, 1)) Then _
                dRDAN.Add Key:=vRDA(v, 1), Item:=vRDN(v, 1)
        Next v
    End With

    'Debug.Print dRDAN.Count & ":" & UBound(vRDN, 1)

    With Worksheets("Prices")
        With .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1, 4)
            .Columns(4).ClearContents
            vPDC = Intersect(.Columns("A:B"), .Cells).Value2
            For v = LBound(vPDC, 1) To UBound(vPDC, 1)
                vPDC(v, 2) = vPDC(v, 2) & vPDC(v, 1)
                vPDC(v, 1) = dRDAN.Item(vPDC(v, 2))
            Next v
            .Cells(1, 4).Resize(UBound(vPDC, 1), 1) = vPDC
        End With
    End With

    'Debug.Print Timer

    dRDAN.RemoveAll: Set dRDAN = Nothing

End Sub

在大内存块中工作的大部分改进是避免循环通过单个工作表单元格。了解数据的性质，关键列中的唯一值以及查找匹配的可能性有助于通过避免不必要的错误控制来设计流程。

虽然这肯定会比VLOOKUP functions更快，但您可以为其添加一些功能。

Answer 2

我在00:00:11测试此代码并运行120K记录，

Sub vlookuptest()
Dim avvio As Date
Dim arresto As Date
Dim tempo As Date
avvio = Now
   Dim findArray(2 To 120000)  As Variant
   For i = 2 To UBound(findArray)
    findArray(i) = Application.WorksheetFunction.VLookup((Worksheets("Prices").Cells(i, 4) & Worksheets("Prices").Cells(i, 3)), Worksheets("Raw Delta").Range("A:O"), 14)
   Next i
   Sheets("Prices").Range("F2:F120000") = findArray
arresto = Now
tempo = arresto - avvio
MsgBox tempo

End Sub

是否可以将其转换为数组/字典以使其更快

2 个答案: