VBA Excel基于匹配的列单元格合并行，将不匹配的数据追加到新列

我四处搜索，试图找到一个现有的解决方案，但我只能找到人们希望将重复数据连接到单个单元格中的变体，我尝试将列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

提前感谢。

假设：

数据位于

Sheet1

结果将显示在

表2中

Sheet1

在

第1行中有标题，数据从
第2行开始

---

---

您是否尝试过以您提到的这样一个示例为例，并根据您的需要对其进行调整？重复的行是否彼此相邻？是的，Thomas我们将在C列AtoZ上订购，以便它们彼此相邻。是否有3个以上的联系人？在极少数情况下，tjb最多可能有10个联系人，我希望每隔10列将其移动到列中，因此，从S开始接触1、AC、AM、AW、BG、BQ、CA、CK、CU、DE。希望这有帮助。这是我修改并最终使用的代码，谢谢Mrig。因此，如果我需要将一些相关信息从C列和J列之间的输入表复制到输出表，我是否能够插入一些额外的行来执行此操作？例如，D:H列与输出表D:H？@JRBB中重复数据消除的公司名称交叉-您可以写入

outputWS.Range（“D”&rowCntr）=inputWS.Range（“D”&rowCntr）

@jrbb-For

D:H

Range write

outputWS.Range（“D”&rowCntr&:“&H”&rowCntr）。Value=inputWS.Range（“D”&rowCntr&:“&rowCntr）.Value

这太好了，谢谢。如果写入第2页的公司名称数量超过2000个，我们可以拆分为第3页吗？在这一点上，每2000个合并的公司会有一个新的表？非常感谢。

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