Question

我已经四处寻找尝试找到现有解决方案，但我只能找到人们希望将重复数据连接到一个单元格中的变体，我试图将行与重复值组合在一起列C并将列J数据附加到几个新列的单个行中。这里的例子;

   Column A     Column C       Column J
        1       Company A      Contact 1
        2       Company A      Contact 2
        3       Company B      Contact 1
        4       Company B      Contact 2
        5       Company B      Contact 3

我需要将其转换为：

Column A    Column C     Column S     Column AC     Column AM
    1       Company A    Contact 1    Contact 2
    2       Company B    Contact 1    Contact 2     Contact 3

提前致谢。

Answer 1

假设：

数据位于Sheet1
结果将显示在Sheet2
Sheet1在Row 1中有标题，数据从Row 2

Sub Demo()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim dict1 As Object
    Dim c1 As Variant
    Dim i As Long, lastRow As Long, count As Long, rowCntr As Long, lRow As Long, lCol As Long
    Dim rFound As Range
    Dim inputWS As Worksheet, outputWS As Worksheet
    Dim arr() As Variant

    'set your sheets here
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set inputWS = ThisWorkbook.Sheets("Sheet1")
    Set outputWS = ThisWorkbook.Sheets("Sheet2")
    'defining columns in array
    arr = Array("S", "AC", "AM", "AW", "BG", "BQ", "CA", "CK", "CU", "DE")

    'get last row with data in Sheet1
    lastRow = inputWS.Cells(Rows.count, "A").End(xlUp).Row
    'put unique compny names in dictionary
    c1 = inputWS.Range("C2:C" & lastRow)
    For i = 1 To UBound(c1, 1)
        dict1(c1(i, 1)) = 1
        Debug.Print c1(i, 1)
    Next i

    rowCntr = 1
    For Each k In dict1.keys
        Debug.Print k, dict1(k)
        'find first occurrence of company name in Column C
        Set rFound = inputWS.Columns(3).Find(What:=k)
        strRow = rFound.Row
        strCol = rFound.Column
        outputWS.Range("A" & rowCntr) = dict1(k)
        outputWS.Range("C" & rowCntr) = rFound
        'get count of each company in column C
        count = Application.WorksheetFunction.CountIf(inputWS.Range("C1:C" & lastRow), rFound)
        For i = 1 To count
            'get all the contact numbers
            outputWS.Range(arr(i - 1) & rowCntr) = inputWS.Range("J" & strRow)
            strRow = strRow + 1
        Next i
        rowCntr = rowCntr + 1
    Next k

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

VBA Excel基于匹配列单元组合行，将非匹配数据附加到新列

1 个答案: