Question

我在找出一个宏来帮助我处理一些数据时遇到了一些麻烦。我遇到了几个宏，它几乎可以满足我的需求，但是我对这种语言知之甚少还没有弄清楚。这就是我正在使用的。

A栏 - 软件清单。

B栏 - 软件版本。

C列 - 安装的计算机名称。

我在寻找什么。我需要一个宏来搜索与A列和B列匹配的重复项。如果它有重复，我需要它将副本和原始行复制到Sheet2。

现在Sheet2应该只有重复的项目。是否有可能再次搜索重复项（A列和B列），当它匹配时，列C的JoinRange在一起。然后删除duplcates。

例： A栏（软件）

Adobe Reader X

Adobe Reader XI

B栏（版本）

10.1.6

10.1.7

11.0.03

C栏（计算机）

计算机1，计算机2

COMPUTER3，Computer4

Computer5，Computer6

Computer7，Computer8

Computer9，Computer10

成品将是：

A栏

Adobe Reader X

Adobe Reader XI

B栏

10.1.6

10.1.7

11.0.03

C栏

计算机1，电脑2，电脑，Computer4

Computer5，Computer6

Computer7，Computer8，Computer9，Computer10

我不确定这是否可行，但我确实可以使用一些指导。

V / R，布雷特

Answer 1

非常简单。添加一个名为＆＃34; Duplicates＆＃34;的工作表，然后选择要检查重复的工作表，然后确保工作表首先按col A排序，然后运行此宏：

    Sub GetDuplicates()
    On Error GoTo errGetDuplicates
    d = 1
    x = 1
    Do Until Cells(x, 1) = "" 'Looks at each row until it reaches the end
        If Cells(x, 1) = Cells(x + 1, 1) Then 'Checks Col 1 for duplicates
            If Cells(x, 2) = Cells(x + 1, 2) Then 'Checks Col 2 for duplicates
                Sheets("Duplicates").Cells(d, 1) = Cells(x, 1)
                Sheets("Duplicates").Cells(d, 2) = Cells(x, 2)
                Sheets("Duplicates").Cells(d, 3) = Cells(x, 3)
                d = d + 1
                x = x + 1
                Sheets("Duplicates").Cells(d, 1) = Cells(x, 1)
                Sheets("Duplicates").Cells(d, 2) = Cells(x, 2)
                Sheets("Duplicates").Cells(d, 3) = Cells(x, 3)
                d = d + 1
            End If
        End If
doneWithError:
        x = x + 1
    Loop

    Exit Sub

errGetDuplicates:
    If Err = 1004 Then
        array1 = Split(Cells(x, 1), " ")
        array2 = Split(Cells(x + 1, 1), " ")

        For a = 0 To UBound(array1)
            If Not array1(a) = array2(a) Then GoTo unmatched
        Next a

        array3 = Split(Cells(x, 2), " ")
        array4 = Split(Cells(x + 1, 2), " ")

        For a = 0 To UBound(array1)
            If Not array3(a) = array4(a) Then GoTo unmatched
        Next a

        Sheets("Duplicates").Cells(d, 1) = Join(array1, " ")
        Sheets("Duplicates").Cells(d, 2) = Join(array3, " ")
        Sheets("Duplicates").Cells(d, 3) = Cells(x, 3)
        d = d + 1
        x = x + 1
        Sheets("Duplicates").Cells(d, 1) = Join(array2, " ")
        Sheets("Duplicates").Cells(d, 2) = Join(array4, " ")
        Sheets("Duplicates").Cells(d, 3) = Cells(x, 3)
        d = d + 1

        GoTo doneWithError

    End If

    End Sub

Excel VBA宏：匹配列A和B，将重复项复制到Sheet2

1 个答案: