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中测试并提供了样本数据

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

End Sub

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

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

3 个答案: