Question

我有两个数据列表。列表A和B都包含字母等级。我想比较数据，如果两个列表都具有相同的字母，我想将该字母移到以C开头的列表C中。如果两个列表没有相同的字母，请将其保持在原位置。我想使用2个数组存储数据，然后为新列表a，b和c创建三个新数组。这是我到目前为止所拥有的。

Sub example1()
Dim ListA As Range, ListB As Range, ListC As Range

    Range("H4:H10").Name = "ListA"
    Range("I4:I6").Name = "ListB"
    Range("J4", Range("J4").End(xlDown)).Name = "ListC"

Dim A(1 To 7), B(1 To 3), i As Integer, j As Integer

    For i = 1 To 7 'stores data in listA in array A
        A(i) = Range("ListA").Cells(i)
    Next
    For j = 1 To 3 'stores data in listB in array B
            B(j) = Range("ListB").Cells(j)
    Next

'select first from ListA and then compare data to listB
' if it is not found, stop and go to next item
'if it IS found, put in list C
Dim isfound As Boolean, letter As Variant, C(1 To 7), k As Integer

For i = 1 To 7
    isfound = False
        For j = 1 To 3
            If A(i) = B(j) Then
                isfound = True
                letter = A(i)
                Exit For
            End If
        Next
        For k = 1 To 7
        C(k) = Range("ListC").Cells(k) 'this is the part I am stuck on. How         
                                      do I get data to paste over to List C?
            If isfound = True Then
            C(k) = A(i) 'this says it will be equal to A(i) value if it is 
                         found.
            End If
        Next
Next
End Sub

Answer 1

类似的事情会起作用：

Sub example1()

    Dim ListA, ListB, ListC(), i As Long, n As Long, m

    ListA = Range("H4:H10").Value
    ListB = Range("I4:I8").Value
    ReDim ListC(1 To UBound(ListA, 1), 1 To 1) 'size the "dups" array
    n = 1

    For i = 1 To UBound(ListA, 1)
        m = Application.Match(ListA(i, 1), ListB, 0) '<< check for match
        If Not IsError(m) Then '<< have a duplicate
            ListC(n, 1) = ListA(i, 1) 'add to ListC
            ListA(i, 1) = ""          '(optional) remove from original lists...
            ListB(m, 1) = ""
            n = n + 1
        End If
    Next i

    'print to sheet...
    Range("K4").Resize(UBound(ListA, 1)).Value = Compact(ListA)
    Range("L4").Resize(UBound(ListB, 1)).Value = Compact(ListB)
    Range("M4").Resize(UBound(ListC, 1)).Value = Compact(ListC)

End Sub

'remove empty array locations...
Function Compact(arr)
    Dim rv(), p As Long, i As Long
    ReDim rv(1 To UBound(arr, 1), 1 To 1)
    For i = 1 To UBound(arr, 1)
        If Len(arr(i, 1)) > 0 Then
            p = p + 1
            rv(p, 1) = arr(i, 1)
        End If
    Next i
    Compact = rv
End Function

这假设listA / B每个都包含唯一值（一个列表中没有重复）

比较两个列表并粘贴到新列表中

1 个答案: