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

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

2 个答案: