当值为A列时合并行是相同的

Question

我在 excel 中有几行数据。

我想合并 A 列中具有相同值的行。我见过一些使用公式的解决方案，但考虑到数据量，我更喜欢使用 VBA。

总体计划是分析每个合并列中最常见的值

发件人：

A   x   x   x   x
B   x   x
B   x   x   x   x   x   x
B   x   x   x
C   x   x
C   x   x   x
C   x   x   x
D   x   x
D   x   x
D   x   x

收件人：

A   x   x   x   x
B   x   x   x   x   x   x   x   x   x   x   x
C   x   x   x   x   x   x   x   x
D   x   x   x   x   x   x

---

我开始用 VBA 写一些东西（它有缺陷），但我想知道是否有更好的方法。

Sub Merge_Row()

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    i = 2
    Sheets("MergeDatabase").Select
    Do Until Cells(i, 1) = ""
        If Cells(i, 1) = Cells(i - 1, 1) Then
            Cells(i, 2).Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Cut
            Cells(i - 1, 1).Select
            Selection.End(xlToRight).Offset(1, 0).Select
            ActiveSheet.Paste
            Rows(i).EntireRow.Delete
        End If
        i = i + 1
    Loop

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

---

感谢您的帮助！

Answer 1

在我的脑海中，除非它没有被粘贴，否则您似乎缺少两个“结束于”实例来结束您的“与”语句。

With application
   .ScreenUpdating = False
   .EnableEvents = False
   .Calculation = xlCalculationManual
End With

Answer 2

下面的版本 1 使用数组和字典，因此速度非常快，但不会复制单元格格式

第 2 版仅使用复制/粘贴会慢一些，但您也可以使用单元格格式

.

版本 1

---

Option Explicit

Public Sub MergeRows1() 'Fast - Array + Dictionary
    Dim ws As Worksheet, arr As Variant, r As Long, c As Long, d As Object
    Dim tc As Long, mc As Long, resultArr As Variant, rVals As Variant

    Set ws = ActiveSheet
    arr = ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1)
    Set d = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arr)            'rows (start under headers)
        For c = 2 To UBound(arr, 2)     'cols (first col = ids)
            If Len(arr(r, 1)) = 0 Or Len(arr(r, c)) = 0 Then Exit For
            If d.Exists(arr(r, 1)) Then
                d(arr(r, 1)) = d(arr(r, 1)) & "||" & arr(r, c)
                mc = UBound(Split(d(arr(r, 1)), "||"))
                If mc > tc Then tc = mc
            Else
                d(arr(r, 1)) = "||" & arr(r, c)
            End If
        Next c
    Next r
    tc = tc + 1:    ReDim resultArr(1 To d.Count, 1 To tc)
    For r = 1 To d.Count
        resultArr(r, 1) = d.Keys()(r - 1)
        rVals = Split(d.Items()(r - 1), "||")
        For c = 1 To UBound(rVals)
            resultArr(r, c + 1) = rVals(c)
        Next c
    Next r
    ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1).Clear
    ws.Range(ws.Cells(2, 1), ws.Cells(d.Count + 1, tc)) = resultArr
End Sub

---

.

第 2 版

---

Public Sub MergeRows2() 'Slow - Copy / Paste (with cell formatting)
    Dim ws As Worksheet, maxC As Long, r As Long, tc As Range, tLC As Long, nLC As Long

    Set ws = ActiveSheet
    maxC = ws.Columns.Count

    Application.ScreenUpdating = False
    For r = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'rows (start under headers)
        Set tc = ws.Cells(r, "A")
        If Len(tc.Offset(1)) = 0 Then Exit For
        While tc.Value2 = tc.Offset(1).Value2
            tLC = ws.Cells(r, maxC).End(xlToLeft).Column
            nLC = ws.Cells(r + 1, maxC).End(xlToLeft).Column
            ws.Range(tc.Offset(1, 1), tc.Offset(1, nLC - 1)).Copy tc.Offset(, tLC)
            ws.Rows(r + 1).Delete
            tLC = tLC + nLC - 1
        Wend
    Next
    Application.ScreenUpdating = True
End Sub

---

.

测试数据

结果