合并包含同一封电子邮件的 Excel 文档中的行并保留合并行的数据

Question

多年来，我曾多次遇到过这样的需求，因此我编写了一个通用例程。我已丢失了该例程的源代码，只能凭记忆重新编写。我已测试了新版本，但不能绝对保证它没有错误，因此在尝试之前请先备份您的数据。

该例程依赖于两个数组。 科尔马奇告诉它哪些列必须相等才能使两行匹配。合并告诉它要合并哪些列。必须在其中一个数组中指定每一列。

对于我的测试数据，我匹配第 1、2、3 和 5 列，并合并第 4 和 6 列。我这样定义：

  ColMatch = Array(1, 2, 3, 5)
  ColMerge = Array(4, 6)

您必须根据您的要求修改这些语句。您的问题暗示它们应该是：

  ColMatch = Array(1, 3, 4)
  ColMerge = Array(2)

该例程还使用一个常数分隔器它位于每个附加值之前。我已将其设置为 vbLf，因此我获取了不同行的每个值。您需要逗号，因此：

  Const Separator As String = ","

我认为您不需要再做任何更改。但是，我建议您仔细研究宏。我希望我已经提供了足够的注释，让您了解它的工作原理。如有必要，请提出问题。

在我的系统上，处理 51,800 行大约需要 2 分钟，因此我使用状态栏作为粗略的进度指示器。

这显示了我的测试数据的初始状态。

我的测试数据的初始状态

这显示了宏运行后它是如何变化的。

宏运行后的数据状态

希望这可以帮助。

Option Explicit
Sub MergeRows()

  ' Merges adjacent rows for which all columns listed in ColMatch are equal
  ' by appending the contents of the other columns from the second row to
  ' the first row and then deleting the second row.

  Dim CheckOK As Boolean
  Dim ColCrnt As Long
  Dim ColLast As Long
  Dim ColMatch() As Variant
  Dim ColMerge() As Variant
  Dim InxMatch As Long
  Dim InxMerge As Long
  Dim RowCrnt As Long
  Dim RowLast As Long
  Dim RowsMatch As Boolean
  Dim TimeStart As Single

  ' Defines the first row to be considered for merging.  This avoids
  ' looking at header rows (not very important) and allows a restart
  ' from row 600 or whatever (might be important).
  Const rowDataFirst As Long = 2

  ' Defines the string to be placed between the value in the first row
  ' and the value from the second row.
  Const Separator As String = vbLf

 ' Speeds up processing
  Application.ScreenUpdating = False

  ' Stops the code from being interrupted by event routines
  Application.EnableEvents = False

  ' Use status bar as a progress indicator
  Application.DisplayStatusBar = True

  ' Record seconds since midnight at start of routine.
  TimeStart = Timer

  ' Defines the columns which must have the same values in two
  ' adjacent rows for the second row to be merged into the
  ' first row.  Column numbers must be in ascending order.
  ColMatch = Array(1, 2, 3, 5)

  ' Defines the columns for which values from the second row
  ' are to be appended to the first row of a matching pair.
  ' Column numbers must be in ascending order.  ColMatch and
  ' ColMerge together must specify every used column.
  ColMerge = Array(4, 6)

  ' Replace "Merge" with the name of your worksheet
  With Worksheets("Merge")

    ' Find last used column and last used row
    ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
                                         xlByColumns, xlPrevious).Column
    RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
                                         xlByRows, xlPrevious).Row

    ' Validate column parameters.  Every column must be specified once
    ' in either ColMatch or ColMerge.
    InxMatch = 0        ' 0 = lower bound of array
    InxMerge = 0
    For ColCrnt = 1 To ColLast
      CheckOK = False   ' Set true if check successful
      If InxMatch > UBound(ColMatch) Then
        ' ColMatch array exhausted
      Else
        If ColCrnt = ColMatch(InxMatch) Then
          CheckOK = True
          InxMatch = InxMatch + 1
        End If
      End If
      If Not CheckOK Then
        If InxMerge > UBound(ColMerge) Then
          ' ColMerge array exhausted
        Else
          If ColCrnt = ColMerge(InxMerge) Then
            CheckOK = True
            InxMerge = InxMerge + 1
          End If
        End If
      End If
      If Not CheckOK Then
        Call MsgBox("I was unable to find column " & ColCrnt & " in either" & _
                    " ColMatch or ColMerge.  Please correct and try again.", _
                                                                       vbOKOnly)
        Exit Sub
      End If
    Next

    RowCrnt = rowDataFirst
    Do While True

      If RowCrnt Mod 100 = 0 Then
        ' Use status bar to indicate progress
        Application.StatusBar = "Row " & RowCrnt & " of " & RowLast
      End If

      ' Attempt to match RowCrnt and RowCrnt+1
      RowsMatch = True    ' Assume match until find otherwise
      For InxMatch = 0 To UBound(ColMatch)
        ColCrnt = ColMatch(InxMatch)
        If .Cells(RowCrnt, ColCrnt).Value <> _
           .Cells(RowCrnt + 1, ColCrnt).Value Then
          ' Rows do not match
          RowsMatch = False
          Exit For
        End If
      Next

      If RowsMatch Then
        ' Rows match.  Merge second into first.
        For InxMerge = 0 To UBound(ColMerge)
          ColCrnt = ColMerge(InxMerge)
          .Cells(RowCrnt, ColCrnt).Value = .Cells(RowCrnt, ColCrnt).Value & _
                                           Separator & _
                                           .Cells(RowCrnt + 1, ColCrnt).Value
        Next
        ' Second row merged into first.  Discard second row.
        .Rows(RowCrnt + 1).EntireRow.Delete
        ' RowLast has moved up.
        RowLast = RowLast - 1
        ' Do not step RowCrnt because there may be another match for it
        If RowCrnt = RowLast Then
          ' All rows checked.
          Exit Do
        End If
      Else
        ' Rows do not match.  RowCrnt no longer of interest.
        RowCrnt = RowCrnt + 1
        If RowCrnt = RowLast Then
          ' All rows checked.
          Exit Do
        End If
      End If
    Loop
  End With

  ' Output duration of macro to Immediate window
  Debug.Print Format(Timer - TimeStart, "#,##0.00")

  Application.StatusBar = False
  Application.EnableEvents = True
  Application.ScreenUpdating = True

End Sub

Answer 1