Excel宏：如果列匹配则合并行

Question

我希望能够组合第一列中的值匹配的行，以便将非空白单元格的值合并为一行。例如：

Mary Smith, A, [blank cell]

Mary Smith, [blank cell], B

-->

Mary Smith A B 

我尝试使用下面的代码：

Dim RowNum As Long, LastRow As Long

Application.ScreenUpdating = False

RowNum = 4

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

Range("A4", Cells(LastRow, 13)).Select

For Each Row In Selection

 With Cells

If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then

 Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 1)

 Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 2)

 Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 3)

Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 4)

Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 5)

Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 6)

 Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 7)

 Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 8)

 Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 9)

 Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 10)

Cells(RowNum + 1, 11).Copy Destination:=Cells(RowNum, 11)

 Cells(RowNum + 1, 12).Copy Destination:=Cells(RowNum, 12)

 Cells(RowNum + 1, 13).Copy Destination:=Cells(RowNum, 13)

Rows(RowNum + 1).EntireRow.Delete

End If

End With

RowNum = RowNum + 1

Next Row

Application.ScreenUpdating = True

'

End Sub

这在整合数据方面做得很好，因此第一列中只有唯一值，但是，当行被复制时，空白单元格的值会复制到填充的单元格上，这不是我想要的。因此，例如，在上述数据上运行此宏将产生：

Mary Smith, A, [blank cell]

Mary Smith, [blank cell], B

-->

Mary Smith, A, [blank cell]

任何关于我如何修改上述代码（或使用更优雅的代码）的见解将不胜感激！

Answer 1

这将很快完成：

Sub foo()
    Dim ws As Worksheet
    Dim lstrow As Long

    Set ws = Sheets("Sheet1") ' Change to your sheet

    With ws
        lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("B4:M" & lstrow)
            .Offset(, 26).FormulaR1C1 = "=IFERROR(INDEX(R4C[-26]:R" & lstrow & "C[-26],MATCH(1,INDEX((R4C1:R" & lstrow & "C1 = RC1)*(R4C[-26]:R" & lstrow & "C[-26] <>""""),),0)),"""")"
            ws.Calculate
            .Value = .Offset(, 26).Value
            .Offset(, 26).ClearContents
        End With
        With .Range("A4:M" & lstrow)
            .Value = .Value
            .RemoveDuplicates 1, xlGuess
        End With
    End With

End Sub

它基本上使用公式：=INDEX(B$4:B$4,MATCH(1,INDEX(($A$4:$A$4 = $A4)*(B$4:B$4 <>""),),0)) 来查找所有值。将这些公式放在空白列中，然后将数据复制回来并删除重复项。

这将一次完成所有 13 列。

它也不关心 A 列中的值重复了多少次。该列中可能有 4 个Mary Smiths。它将抓取每列中的第一个值并使用它。

之前：

之后：

Answer 2

试试下面的代码

Sub test()
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 4 To LastRow
        If ((Range("A" & i).Value = Range("A" & i + 1).Value) And (Range("B" & i).Value <> Range("B" & i + 1).Value) And ((Range("B" & i).Value = "") Or (Range("B" & i + 1).Value = "")) And (Range("C" & i).Value <> Range("C" & i + 1).Value) And ((Range("C" & i).Value = "") Or (Range("C" & i + 1).Value = ""))) Then
            If Range("B" & i).Value = "" Then
                Range("B" & i).Value = Range("B" & i + 1).Value
            ElseIf Range("B" & i + 1).Value = "" Then
                Range("B" & i + 1).Value = Range("B" & i).Value
            End If
            If Range("C" & i).Value = "" Then
                Range("C" & i).Value = Range("C" & i + 1).Value
            ElseIf Range("C" & i + 1).Value = "" Then
                Range("C" & i + 1).Value = Range("C" & i).Value
            End If
        End If
        Range("B" & i).EntireRow.Delete Shift:=(xlUp)
        LastRow = LastRow - 1
    Next i
End Sub

Answer 3

这是另一种方法。 创建一个人员对象。每个 Personnel 对象可以有多个属性（原始表中的非空白列条目）。

通过使用集合对象的 Key 属性，并使用 Name（column1 数据）作为键，我们可以检测重复，而无需对原始数据进行排序。并且每个名称的属性数量仅受工作表大小的限制。

其他信息在 cmets 中。

插入一个类对象并重命名它cPersonnel

下面是 Class 和 Regular 模块的代码

类模块

Option Explicit
Private pName As String
Private pAttrib As String
Private pAttribs As Collection

Public Property Get Name() As String
    Name = pName
End Property
Public Property Let Name(Value As String)
    pName = Value
End Property

Public Property Get Attrib() As String
    Attrib = pAttrib
End Property
Public Property Let Attrib(Value As String)
    pAttrib = Value
End Property

Public Property Get AttribS() As Collection
    Set AttribS = pAttribs
End Property
Public Function ADDAttribS(Value As String)
    pAttribs.Add Value
End Function

Private Sub Class_Initialize()
    Set pAttribs = New Collection
End Sub

常规模块

Option Explicit
Sub PersonnelAttribs()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim cP As cPersonnel, colP As Collection
    Dim LastRow As Long, LastCol As Long
    Dim I As Long, J As Long

'Set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc.Cells
    LastRow = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
        searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    LastCol = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
        searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With

'Read source data into array
With wsSrc
    vSrc = Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

'create and collect the Personnel objects
'Source data does not need to be sorted
Set colP = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
    If Trim(vSrc(I, 1)) <> "" Then
        Set cP = New cPersonnel
        With cP
            .Name = vSrc(I, 1)
            For J = 2 To UBound(vSrc, 2)
                If Trim(vSrc(I, J)) <> "" Then
                    .Attrib = Trim(vSrc(I, J))
                    .ADDAttribS .Attrib
                End If
            Next J
            colP.Add cP, .Name
            Select Case Err.Number
                Case 457 'duplicate name
                    Err.Clear
                    For J = 1 To .AttribS.Count
                        colP(.Name).ADDAttribS .AttribS(J)
                    Next J
                Case Is <> 0
                    Debug.Print Err.Number, Err.Description
                    Stop
            End Select
        End With
    End If
Next I
On Error GoTo 0

'Create results array
'Number of columns
For I = 1 To colP.Count
With colP(I)
    J = IIf(J > .AttribS.Count, J, .AttribS.Count)
End With
Next I

ReDim vRes(0 To colP.Count, 0 To J)

'Headers
vRes(0, 0) = "Name"
For J = 1 To UBound(vRes, 2)
    vRes(0, J) = "Attrib " & J
Next J

'Populate data
For I = 1 To colP.Count
With colP(I)
    vRes(I, 0) = .Name
    For J = 1 To .AttribS.Count
        vRes(I, J) = .AttribS(J)
    Next J
End With
Next I

'Clear old data and write new
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With   
End Sub

原始数据

宏之后的结果