当列标题相同时，合并所有行中的值

另一个棘手的问题。 我有一个与另一个macros清理的数据集，在那里我需要遍历列标题和每一行，合并列的值与第一列中相同的标题名称，由;分隔;

样本数据：

 Test Country Test Country 123 456 789 012 abc def ghi jkl mno pqr stu vwx 

期望的输出：

 Test Country 123;789 456;012 abc;ghi def;jkl 

我试过这样的东西肯定没用

  Dim i As Long i = 1 j = 1 Do Until Len(Cells(i, j).Value) = 0 If Cells(i, j).Value = Cells(i, j + 1).Value Then Cells(i, j).Value = Cells(i, j).Value & ";" & Cells(i, j + 1).Value Rows(j + 1).Delete Else i = i + 1 j = j + 1 End If Loop 

Answer 1

经过一个很好的聊天，如同意…

 Sub ForLoopPair() Dim lastRow As Integer: lastRow = Cells(xlCellTypeLastCell).Row ' or w/e you had Dim lastCol As Integer: lastCol = Cells(xlCellTypeLastCell).Column ' or w/e you had For DestCol = 1 To lastCol For ReadCol = DestCol + 1 To lastCol If Cells(1, DestCol) = Cells(1, ReadCol) Then For i = 2 To lastRow If Cells(i, ReadCol) <> "" Then Cells(i, DestCol) = Cells(i, DestCol) & ";" & Cells(i, ReadCol) End If Next i End If Next ReadCol Next DestCol For DestCol = 1 To lastCol If Cells(1, DestCol) = "" Then Exit For For ReadCol = lastCol To (DestCol + 1) Step -1 If Cells(1, DestCol) = Cells(1, ReadCol) Then Columns(ReadCol).Delete End If Next Next End Sub 

Answer 2

不确定第一个答案有什么不同，但是这个是在Excel 2010中提供的示例数据

Sub B（）

  Dim DestCol As Integer Dim ReadCol As Integer DestCol = 1 ReadCol = 2 While ActiveSheet.Cells(1, DestCol) <> "" If ActiveSheet.Cells(1, ReadCol) = ActiveSheet.Cells(1, DestCol) Then For i = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row If ActiveSheet.Cells(i, ReadCol) <> "" Then ActiveSheet.Cells(i, DestCol) = ActiveSheet.Cells(i, DestCol) & ";" & ActiveSheet.Cells(i, ReadCol) End If Next i ActiveSheet.Columns(ReadCol).Delete ElseIf ActiveSheet.Cells(1, ReadCol + 1) <> "" Then ReadCol = ReadCol + 1 Else ReadCol = DestCol + 2 DestCol = DestCol + 1 End If Wend 

结束小组

Answer 3

试试这个（testing）

 Option Explicit Sub Main() Dim rng As Range, cell As Range, cell2 As Range, cell3 As Range, rngToDelete As Range Dim txt As String With Worksheets("myWorksheetName") With .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)) Set rngToDelete = .Offset(1).Resize(, 1) For Each cell In .Cells If Intersect(cell, rngToDelete) Is Nothing Then Set rng = GetRange(cell, .Cells) If Not rng Is Nothing Then With Intersect(.Parent.UsedRange, cell.EntireColumn) MsgBox .Offset(1).Resize(.Rows.Count - 1).SpecialCells(XlCellType.xlCellTypeConstants).Address For Each cell2 In .Offset(1).Resize(.Rows.Count - 1).SpecialCells(XlCellType.xlCellTypeConstants) txt = cell2.Value For Each cell3 In rng txt = txt & ";" & .Parent.Cells(cell2.row, cell3.Column) Next cell3 cell2.Value = txt Next cell2 End With Set rngToDelete = Union(rng, rngToDelete) End If End If Next cell Intersect(.Cells, rngToDelete).EntireColumn.Delete End With End With End Sub Function GetRange(rngToSearchFor As Range, rngToSearchIn As Range) As Range Dim f As Range Dim firstAddress As String With rngToSearchIn Set f = .Find(What:=rngToSearchFor.Value, lookAt:=xlWhole, LookIn:=xlValues, After:=rngToSearchFor, SearchDirection:=xlNext) If Not f Is Nothing Then If f.Column > rngToSearchFor.Column Then firstAddress = f.Address Set GetRange = f Do Set GetRange = Union(GetRange, f) Set f = .FindNext(f) Loop While f.Column > rngToSearchFor.Column End If End If End With End Function