一个更快的替代我的 vlookup 代码块？

时间：2021-07-04 00:29:45

标签： excel vba vlookup

表 'kw30'、'kw60' 和 'kw90' 大约有 20k 行。 “bulkexport”表大约有 30 万行。

仅此部分就需要大约 20 分钟的时间来执行。

有没有更快的方法来解决这个问题或重构它？我试图想办法将“bulkexport”表的底部三分之一分成多个部分，以便 vlookup 一次只查看一小部分...

感谢任何输入。

谢谢！！ 数据

    Sheets("kw90").Select
    For i = 2 To kw90rowcount
        On Error Resume Next

        
        Range("ac" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:y" & kw60rowcount), 2, False)
        Range("ad" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:z" & kw60rowcount), 3, False)
        Range("ae" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:aa" & kw60rowcount), 4, False)
        Range("ai" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:ab" & kw60rowcount), 5, False)
        Range("aj" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:ac" & kw60rowcount), 6, False)
        
        Range("af" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:y" & kw30rowcount), 2, False)
        Range("ag" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:z" & kw30rowcount), 3, False)
        Range("ah" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:aa" & kw30rowcount), 4, False)
        Range("ak" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:ab" & kw30rowcount), 5, False)
        Range("al" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:ac" & kw30rowcount), 6, False)
        
        
        Range("y" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("ac2:ad" & bulkexportrowcount), 2, False)
        Range("z" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("ad2:ae" & bulkexportrowcount), 3, False)
        Range("aa" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("ae2:af" & bulkexportrowcount), 4, False)
        Range("ab" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("af2:ag" & bulkexportrowcount), 5, False)
        
        
    Next i

4 个答案:

答案 0 :(得分：2)

如果您切换到 Match() 来定位正确的行（您只需要为每个源数据集的每行执行一次...），您当前的方法会更快一点 - 然后您可以提取所需的单元格直接来自该行的值。

Sub UseMatch()
   
    Dim i As Long, m, rw As Range, xVal, arr
    Dim wsKW60 As Worksheet
    
    Set wsKW60 = Worksheets("kw60")
    
    For i = 2 To kw90rowcount
        
        Set rw = Sheets("kw90").Rows(i)
        xVal = rw.Columns("X").Value
        
        'find the row once
        m = Application.Match(xVal, wsKW60.Range("x1:x" & kw60rowcount), 0)
        If Not IsError(m) Then
            arr = wsKW60.Cells(m, "Y").Resize(1, 5).Value 'got a row - read all values in one operation
            rw.Columns("AC").Value = arr(1, 1)            'then assign values from the array
            rw.Columns("AD").Value = arr(1, 2)
            rw.Columns("AE").Value = arr(1, 3)
            rw.Columns("AI").Value = arr(1, 4)
            rw.Columns("AJ").Value = arr(1, 5)
        End If
        
        'next sheets ...

    Next i
End Sub

答案 1 :(得分：1)

如前所述，考虑一个数据库来匹配和查找不同大集合之间的值。然后，将 Excel 用作最终用途的分析/报告工具，而不是用于数据存储。这样做，SQL 可以取代 vlookup 公式并避免任何循环。 （可能，所有三个连接都可以在一个查询中使用，但对您的数据了解得不够多，您可能在 x 列上存在多对多关系。）

SELECT kw90.*, kw60.y, kw60.z, kw60.aa, kw60.ab, kw60.ac
FROM kw90
INNER JOIN kw60 ON kw90.x = kw60.x

SELECT kw90.*, kw30.y, kw30.z, kw30.aa, kw30.ab, kw30.ac
FROM kw90
INNER JOIN kw60 ON kw90.x = kw30.x

SELECT kw90.*, kw60.y, kw60.z, kw60.as, kw60.ab, kw60.ac
FROM kw90
INNER JOIN bulkexport ON kw90.x = bulkexport.x

实际上，如果使用 Excel for PC，您也可以在工作簿上运行 SQL。 Excel 可以连接到 Jet/ACE SQL 引擎（Window .dll 文件）以在工作表上运行查询，就像它们是数据库表一样。

例如，下面的查询在两个工作表 kw90 和 kw60 之间运行 INNER JOIN，并输出到现有工作表 Results . （SQL 中应该使用命名列而不是字母位置。）

Sub RunSQL()    
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer
    
    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    
    ' CONNECTION STRINGS (DRIVER VERSION COMMENTED OUT)
'    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
'                      & "DBQ=C:\Path\To\Workbook.xlsm;"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='C:\Path\To\Workbook.xlsm';" _
                       & "Extended Properties=""Excel 12.0;HDR=YES;"";"
    
    strSQL = "SELECT kw90.*, " _
             & "     kw60.y, kw60.z, kw60.as, kw60.ab, kw60.ac "_
             & "FROM [kw90$] AS kw90" _
             & "INNER JOIN [kw60$] AS kw60 ON kw90.x = kw60.x" 
      
    ' OPEN CONNECTION
    conn.Open strConnection
    rst.Open strSQL, conn
    
    ' COLUMN HEADERS
    For i = 1 To rst.Fields.Count - 1
        Worksheets("Results").Cells(1, i) = rst.Fields(i).Name
    Next i        
    ' DATA ROWS
    Worksheets("Results").Range("A2").CopyFromRecordset rst
        
    rst.Close: conn.Close   
    Set rst = Nothing: Set conn = Nothing 
End Sub

答案 2 :(得分：0)

我不确定访问是否是一个好的解决方案，因为每天都会将新报告粘贴到所有这些工作表中，然后运行脚本 - 它们不包含静态值。

关于字典，我将不得不研究一下，因为我没有这方面的经验。这和数组一样吗？

如果首先按字母顺序对所有工作表进行排序，vlookup 会更快吗？

我也有一个想法，请让我知道您的意见 - 我想尝试根据之前的结果使 vlookup 范围动态化 - 如果一切都按字母顺序排列并且初始范围是第 1 行到 300k 并且第一个结果是在第 1000 行，下一次查找可以是从第 1001 行到第 300k 行，因为我知道第 1-1000 行不会有结果。有意义吗？

谢谢

答案 3 :(得分：0)

VBA 查找 (Application.Match)

  • 调整常量部分中的值。
Option Explicit

Sub VBALookup()
    
    Const s1Name As String = "kw60"
    Const s1First As String = "X2"
    Const s1ColsList As String = "Y,Z,AA,AB,AC"
    
    Const s2Name As String = "kw30"
    Const s2First As String = "X2"
    Const s2ColsList As String = "Y,Z,AA,AB,AC"
    
    Const s3Name As String = "bulkexport"
    Const s3First As String = "AC2"
    Const s3ColsList As String = "AD,AE,AF,AG"
    
    Const lName As String = "kw90"
    Const lFirst As String = "X2"
    
    Const dName As String = "kw90"
    Const dFirst As String = "Y2"
    
    Dim d1Cols As Variant: d1Cols = VBA.Array(5, 6, 7, 11, 12)
    Dim d2Cols As Variant: d2Cols = VBA.Array(8, 9, 10, 13, 14)
    Dim d3Cols As Variant: d3Cols = VBA.Array(1, 2, 3, 4)
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lfCell As Range: Set lfCell = lws.Range(lFirst)
    Dim llRow As Long: llRow = GetLastRow(lfCell)
    If llRow = 0 Then Exit Sub
    Dim lrg As Range
    Set lrg = lws.Range(lFirst, lws.Cells(llRow, lfCell.Column))
    Dim lData As Variant: lData = GetColumn(lrg)
    
    ' Destination (Array)
    Dim drCount As Long: drCount = UBound(lData)
    Dim dcCount As Long
    dcCount = UBound(d1Cols) + UBound(d2Cols) + UBound(d3Cols) + 3
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' Source
    SourceToArray dData, wb, s1Name, s1First, s1ColsList, drCount, lData, d1Cols
    SourceToArray dData, wb, s2Name, s2First, s2ColsList, drCount, lData, d2Cols
    SourceToArray dData, wb, s3Name, s3First, s3ColsList, drCount, lData, d3Cols
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    dfCell.Resize(drCount, dcCount).Value = dData
    
End Sub

Sub SourceToArray( _
        ByRef dData As Variant, _
        ByVal wb As Workbook, _
        ByVal sName As String, _
        ByVal sFirst As String, _
        ByVal sColsList As String, _
        ByVal drCount As Long, _
        ByVal lData As Variant, _
        ByVal dCols As Variant)

    On Error Resume Next
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    On Error GoTo 0
    If sws Is Nothing Then Exit Sub
    
    Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
    Dim slRow As Long: slRow = GetLastRow(sfCell)
    If slRow = 0 Then Exit Sub
    
    Dim srg As Range
    Set srg = sws.Range(sFirst, sws.Cells(slRow, sfCell.Column))
    Dim sCols() As String: sCols = Split(sColsList, ",")
    Dim scUpper As Long: scUpper = UBound(sCols)
    Dim sData As Variant: ReDim sData(0 To scUpper)
    
    Dim n As Long
    For n = 0 To scUpper
        sData(n) = GetColumn(srg.EntireRow.Columns(sCols(n)))
    Next n
    
    Dim rIndex As Variant
    Dim r As Long
    For r = 1 To drCount
        rIndex = Application.Match(lData(r, 1), srg, 0)
        If IsNumeric(rIndex) Then
            For n = 0 To scUpper
                dData(r, dCols(n)) = sData(n)(rIndex, 1)
            Next n
        End If
    Next r

End Sub

Function GetLastRow( _
    ByVal FirstRowRange As Range) _
As Long
    If FirstRowRange Is Nothing Then Exit Function
    Dim frrg As Range: Set frrg = FirstRowRange.Rows(1)
    Dim lCell As Range
    Set lCell = frrg.Resize(frrg.Worksheet.Rows.Count - frrg.Row + 1) _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If lCell Is Nothing Then Exit Function
    GetLastRow = lCell.Row
End Function

Function GetColumn( _
    ByVal ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    Dim crg As Range: Set crg = ColumnRange.Columns(1)
    Dim cData As Variant
    If crg.Rows.Count = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
    Else
        cData = crg.Value
    End If
    GetColumn = cData
End Function
相关问题
最新问题