比较两个范围并通过插入新行来添加缺失的条目？

Question

我有两个范围 (A4:C13) 和 (E4:G13)，我想比较 A 列 (A4:A13) 和 E 列 (E4:E13) 如果任一列中缺少任何值然后它应该添加缺失值并用 0 填充其他行，如附图所示。知道如何实现这一目标吗？到目前为止，我发现以下代码将值添加到一列中，但不添加到另一列中。我应该运行将这段代码用于另一列，还是有其他简单的方法来做到这一点？

Sub test()
Dim cl As Range

Set cl = Range("D1")

Do While cl.Row < 10
  If cl.Value <> cl.Offset(0, -3).Value Then
    cl.Offset(0, 1).Insert Shift:=xlDown
    cl.Insert Shift:=xlDown
    Set cl = cl.Offset(-1, 0)
  End If
  Set cl = cl.Offset(1, 0)
Loop
End Sub

Answer 1

这个做的很到位：

Sub testdddd()
Dim cl1 As Range
Dim cl2 As Range
Dim rng1 As Range
Dim rng2 As Range
Dim fnd As Range
Dim arr() As Variant
With ActiveSheet
    Set rng1 = .Range(.Cells(4, 1), .Cells(4, 1).End(xlDown))
    Set rng2 = .Range(.Cells(4, 5), .Cells(4, 5).End(xlDown))
    'rng2.Select
    For Each cl1 In rng1
        Set fnd = rng2.Find(cl1)
        If fnd Is Nothing Then
            arr = Array(cl1, 0, 0)
            rng2.Cells(rng2.Rows.count + 1, 1).Resize(, 3) = arr
            Set rng2 = .Range(.Cells(4, 5), .Cells(4, 5).End(xlDown))

        End If
    Next cl1

    rng2.Resize(rng2.Rows.count, 3).Sort rng2.Cells(1, 1)

    For Each cl2 In rng2
    Set fnd = rng1.Find(cl2)
    If fnd Is Nothing Then
        arr = Array(cl2, 0, 0)
        rng1.Cells(rng1.Rows.count + 1, 1).Resize(, 3) = arr
        Set rng1 = .Range(.Cells(4, 1), .Cells(4, 1).End(xlDown))
        rng1.Select
    End If
    Next cl2
    rng1.Resize(rng1.Rows.count, 3).Sort rng1.Cells(1, 1)
End With
End Sub

Answer 2

试试这个代码：

Sub Rng_Compare_B()
Dim RngA As Range, RngB As Range
Dim lValA As Long, lValB As Long
Dim vMatch As Variant, lRow As Long

    With ActiveSheet.Rows(4)
        Set RngA = .Cells(1).CurrentRegion
        Set RngB = .Cells(5).CurrentRegion
    End With

    Do

        lRow = 1 + lRow
        lValA = RngA.Cells(lRow, 1).Value2
        lValB = RngB.Cells(lRow, 1).Value2

        If lValA = Empty And lValB = Empty Then Exit Do

        Rem Compares Range A vs B - Adjust B
        If lValA <> Empty Then
            vMatch = 0
            On Error Resume Next
            vMatch = WorksheetFunction.Match(lValA, RngB.Columns(1), 0)
            On Error GoTo 0
            If vMatch = 0 Then
                RngB.Rows(lRow).Insert Shift:=xlDown
                RngB.Rows(lRow).Value = Array(lValA, 0, 0)
                GoTo Loop_Next
        End If: End If

        Rem Compares Range B vs A - Adjust A
        If lValB <> Empty Then
            vMatch = 0
            On Error Resume Next
            vMatch = WorksheetFunction.Match(lValB, RngA.Columns(1), 0)
            On Error GoTo 0
            If vMatch = 0 Then
                RngA.Rows(lRow).Insert Shift:=xlDown
                RngA.Rows(lRow).Value = Array(lValB, 0, 0)
        End If: End If

Loop_Next:
    Loop

End Sub

比较两个范围并通过插入新行来添加缺失的条目？

compare two range and add missing entries by inserting a new row?

excel

vba

compare

range