Vba插入缺失记录

Question

在您的网站上，我发现这段代码可以回答与我相同的问题。 我试图将其适合我的数据，但什么也没有。 表(2) A 列中的数据：E 比较 E 列 Sheet(1)A列数据：K比较K列 起始行 = 2(A2)

Sub Main()
Dim source As Worksheet
Dim target As Worksheet
Dim dictSource As Object
Dim dictTarget As Object
Dim rng As Range
Dim i As Integer
Dim j As Integer
Dim idSource As String
Dim idTarget As String
Dim offset As Integer

Set source = ThisWorkbook.Sheets(2)
Set target = ThisWorkbook.Sheets(1)

offset = 1 'My data starts at row 10, so the offset will be 9

Set rng = source.Range("A2:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row)
Set dictSource = CreateObject("Scripting.Dictionary")
For Each cell In rng
Set dictSource.Item(cell.Value) = cell
Next

Set rng = target.Range("A2:K" & target.Cells(target.Rows.Count, "A").End(xlUp).Row)
Set dictTarget = CreateObject("Scripting.Dictionary")
For Each cell In rng
 Set dictTarget.Item(cell.Value) = cell
Next

i = 1
j = source.Range("A2:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row).Rows.Count
Do While i <= j
Retry:
idSource = source.Cells(i + offset, 1).Value
idTarget = target.Cells(i + offset, 11).Value
If Not (dictSource.Exists(idTarget)) And idTarget <> "" Then
'Delete unwanted rows
target.Cells(i + offset, 1).EntireRow.Delete
GoTo Retry
End If
If dictTarget.Exists(idSource) Then
'The identifier was found so we can update the values here...
dictTarget.Remove (idSource)
ElseIf idSource <> "" Then
'The identifier wasn't found so we can insert a row
target.Cells(i + offset, 1).EntireRow.Insert
'And you're ready to copy the values over
target.Cells(i + offset, 11).Value = idSource
End If
i = i + 1
Loop

Set dictSource = Nothing
Set dictTarget = Nothing
End Sub

Answer 1

使用目标工作表上 K 列的键构建字典，然后扫描与 E 列值匹配的源工作表。如果不匹配，则将源记录添加到目标工作表的底部。如果顺序很重要，请在最后对纸张进行排序，

Option Explicit

Sub Process()

    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim targetLast As Long, sourceLast As Long, r As Long
    Dim dict As Object, k, i As Long, d As Long
    Set dict = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook
        Set wsTarget = .Sheets("Sheet1")
        Set wsSource = .Sheets("Sheet2")
    End With
    
    ' build dictionary of Target column K values
    With wsTarget
        targetLast = .Cells(.Rows.Count, "K").End(xlUp).Row
        For r = 2 To targetLast
            k = Trim(.Cells(r, "K"))
            If dict.exists(k) Then
                MsgBox wsTarget.Name & " - Duplicate key " & k & " at row " & r, vbCritical
                Exit Sub
            ElseIf Len(k) > 0 Then
                dict.Add k, r
            End If
        Next
    End With
    
    ' scan source
    Application.ScreenUpdating = False
    With wsSource
        ' scan source match colum E
        sourceLast = .Cells(.Rows.Count, "E").End(xlUp).Row
        For r = 2 To sourceLast
            k = Trim(.Cells(r, "E"))
            If dict.exists(k) Then
                ' match
                dict.Remove k
            Else
                ' no match - copy to bottom of target sheet
                i = i + 1
                .Cells(r, "A").Resize(1, 4).Copy wsTarget.Cells(targetLast + i, "A")
                .Cells(r, "E").Copy wsTarget.Cells(targetLast + i, "K")
                wsTarget.Rows(targetLast + i).Interior.Color = vbGreen
            End If
        Next
    End With
    
    ' delete not matched
    Dim rng As Range
    d = dict.Count
    If d > 0 Then
        With wsTarget
            For Each k In dict
                r = dict(k)
                If rng Is Nothing Then
                   Set rng = .Rows(r)
                Else
                   Set rng = Union(.Rows(r), rng)
                End If
            Next
        End With
        rng.Interior.Color = vbRed
        'rng.Delete
    End If
    Application.ScreenUpdating = False

    MsgBox i & " records inserted, " & d & " deleted", vbInformation
    
End Sub