Excelmacros：如果列匹配，则合并行
我希望能够合并第一列中的值匹配的行，以便将非空白单元格的值合并到一行中。 例如：
Mary Smith, A, [blank cell] Mary Smith, [blank cell], B – >
Mary Smith AB
我试过使用下面的代码：
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
这在整合数据方面做得很好，因此在第一列中只有唯一的值，但是当行被复制时，空白单元格的值将复制到填充的单元格中，而不是我想要的。 所以举个例子，在上面的数据上运行这个macros会产生：
Mary Smith, A, [blank cell] Mary Smith, [blank cell], B
– >
Mary Smith, A, [blank cell]
任何深入了解如何修改上述代码（或使用更优雅的东西）将不胜感激！
这将很快做到这一点：
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))find所有的值。 将这些公式放在空白列中，然后将数据复制回去并删除重复项。
这将一次完成所有13列。
它也不关心A列中的值重复多less次。 那个专栏里可能有4个Mary Smith 。 它将获取每列中的第一个值并使用它。
之前：
后：
尝试下面的代码
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
这是另一种方法。 创build一个Personnel对象。 每个人员对象可以有多个属性（原始表中的非空列列）。
通过使用集合对象的Key属性，并使用Name（column1数据）作为关键字，我们可以检测重复项，而无需对原始数据进行sorting。 而每个名称的属性数量仅受工作表大小的限制。
其他信息在评论中。
插入一个类对象并将其重命名为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
原始数据
macros后的结果
