时间戳

首页 > 解决方案 > 有没有一种更快或更聪明的方法来为每个人做 2 个？

excel - 有没有一种更快或更聪明的方法来为每个人做 2 个？

问题描述

我想将一个表中的单元格值添加到另一个表中。第一个表包含大约 110 000 行 (tabCDL) 和其他大约 37 000 行 (tabEMP)。现在大约需要一个小时，我需要做得更快。

Public Sub MergeColumnEMP()

    'Merge

    Dim cel, cel2, rngCDL, rngEMP As Range
    Dim shtCDL, shtEMP As Worksheet
    Dim LastRowCDL, LastRowEMP As Long
    
    Set shtCDL = Sheets("CEDULE")
    Set shtEMP = Sheets("EMPRUNT")
    LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.Rows.Count
    LastRowEMP = shtEMP.ListObjects("TabEMP").Range.Rows.Count
    Set rngCDL = Sheets("CEDULE").Range("H2:H" & LastRowCDL)
    Set rngEMP = Sheets("EMPRUNT").Range("C2:C" & LastRowEMP)
    
    For Each cel In rngCDL
    
        For Each cel2 In rngEMP
        
            If cel.Value = cel2.Value Then
            
                'amount
                Sheets("CEDULE").Range("I" & cel.Row).Value = Sheets("EMPRUNT").Range("D" & cel2.Row).Value
                'Date dstart
                Sheets("CEDULE").Range("J" & cel.Row).Value = Sheets("EMPRUNT").Range("H" & cel2.Row).Value
                'Date end
                Sheets("CEDULE").Range("K" & cel.Row).Value = Sheets("EMPRUNT").Range("I" & cel2.Row).Value
             
                Exit For
                
            End If
        
        Next cel2
    
    Next cel
    
    Debug.Print "DONE merging"

End Sub

标签： excelvba

解决方案

请尝试下一个方法。它使用数组并且应该非常快。未经测试，但如果我没有弄乱所涉及范围的任何内容，它应该可以工作：

Sub MergeColumnEMP() 'unique in EMP, not unique in CEDULE
    Dim arrCDL, arrEMP, rngCopy As Range, i As Long, j As Long
    Dim shtCDL As Worksheet, shtEMP As Worksheet
    Dim LastRowCDL As Long, LastRowEMP As Long
    
    Set shtCDL = Sheets("CEDULE")
    Set shtEMP = Sheets("EMPRUNT")
    LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.rows.Count
    LastRowEMP = shtEMP.ListObjects("TabEMP").Range.rows.Count
    
    arrCDL = shtCDL.Range("H2:K" & LastRowCDL).value            'h
    arrEMP = Sheets("EMPRUNT").Range("C2:I" & LastRowEMP).value 'c
    
    For i = 1 To UBound(arrCDL)
        For j = 1 To UBound(arrEMP)
            If arrCDL(i, 1) = arrEMP(j, 1) Then
                arrCDL(i, 2) = arrEMP(j, 2)
                arrCDL(i, 3) = arrEMP(j, 5)
                arrCDL(i, 4) = arrEMP(j, 6)
                Exit For
            End If
        Next j
    Next i
    shtCDL.Range("H2").Resize(UBound(arrCDL), UBound(arrCDL, 2)).value = arrCDL
    
    MsgBox "DONE merging"
End Sub

编辑：

请同时测试下一个代码，它应该更快：

Sub MergeColumnEMPLast() 'unique in EMP, not unique in CEDULE
    Dim arrCDL, arrEMP, rngCopy As Range, i As Long, j As Long
    Dim shtCDL As Worksheet, shtEMP As Worksheet
    Dim LastRowCDL As Long, LastRowEMP As Long
    Dim dict As New Scripting.Dictionary, iMatch As Variant
    
    Set shtCDL = Sheets("CEDULE")
    Set shtEMP = Sheets("EMPRUNT")
    LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.rows.Count
    LastRowEMP = shtEMP.ListObjects("TabEMP").Range.rows.Count
    
    arrCDL = shtCDL.Range("H2:K" & LastRowCDL).value 'h
    arrEMP = shtEMP.Range("C2:I" & LastRowEMP).value 'c
    
    For i = 1 To UBound(arrCDL)
        If dict.Count > 0 Then iMatch = Application.match(arrCDL(i, 1), dict.Keys, 0)
        If Not IsError(iMatch) Then
            If dict.Count > 0 Then
               If iMatch <> dict.Count Or (iMatch = dict.Count And arrCDL(i, 1) = dict.Keys(dict.Count - 1)) Then
                  arrCDL(i, 2) = dict.items(iMatch - 1)(0)
                  arrCDL(i, 3) = dict.items(iMatch - 1)(1)
                  arrCDL(i, 4) = dict.items(iMatch - 1)(2)
                  GoTo OverIteration
               End If
            End If
        End If
        For j = 1 To UBound(arrEMP)
            If arrCDL(i, 1) = arrEMP(j, 1) Then
                arrCDL(i, 2) = arrEMP(j, 2)
                arrCDL(i, 3) = arrEMP(j, 6)
                arrCDL(i, 4) = arrEMP(j, 7)
                dict.Add arrCDL(i, 1), Array(arrEMP(j, 2), arrEMP(j, 6), arrEMP(j, 7))
                Exit For
            End If
        Next j
OverIteration:
    Next i
    shtCDL.Range("H2").Resize(UBound(arrCDL), UBound(arrCDL, 2)).value = arrCDL
    
    MsgBox "DONE merging"
End Sub

我只是好奇你的范围需要多少...

推荐阅读