當列標題相同時合併所有行中的值

Question

另一個棘手的問題。我有一個清理的數據集與另一個宏，我需要遍歷列標題和每一行，在第一列中合併具有相同標題名稱的列的值，由;

示例數據：

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（）提供

分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

試試這個（測試）

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