Question

另一个不那么容易的问题。使用VBA，我需要迭代具有相似名称（不精确）的列标题，并将;中第一个中的值组合起来。

示例数据：

A (1) B (1) C (1) A (2) B (2) C (2) A(3) B (3) C (3) 
 15     25    35    45    100  200  300   600   700

应该是动态的，删除额外的列（很多值也是空白的，需要考虑：

A (1)            B (1)        C (1)  
15;45;300     25;100;600   35;200;700

编辑：更改数据结构更准确

我首先猜测我需要循环和清理数据，因此它们具有相同的名称，因为这是唯一匹配的东西。

For i = 1 to lastCol Step 1
    columnVal = ws.Cells(1, i).Value
      If InStr(columnVal, "(") Then
         'Remove everything after first "("
      End If
       For j = 1 to lastCol
           For k = 1 to lastCol
              If ws.Cells(1, j).Value = ws.Cells(1, k).Value Then
                 'Create array with combined values
              End if
            Next k
        Next j

不确定这是否是正确的做法，所以感谢任何帮助

Answer 1

你可以如下：

Option Explicit

Sub main()
    With Worksheets("CombineColumns") '<--| change "CombineColumns" to your actual worksheet name
        With .Range("B2").CurrentRegion '<--| change "B2" to your actual topleftmost cell
            SortRange .Cells '<-- sort columns by their header
            .Rows(1).Replace what:="(*)", replacement:="(1)", lookat:=xlPart '<-- make all "similar" header the same
            Aggregate .Cells '<-- aggregate values under each different unique header
        End With
    End With
End Sub

Sub Aggregate(rng As Range)
    Dim header As String, resStrng As String
    Dim iLastCol As Long, iCol As Long

    With rng
        header = .Cells(1, 1).Value
        iCol = 2
        iLastCol = 1
        resStrng = .Cells(2, 1)
        Do
            If .Cells(1, iCol) = header Then
                resStrng = resStrng & ";" & .Cells(2, iCol)
            Else
                .Cells(2, iLastCol).Value = resStrng
                .Cells(1, iLastCol + 1).Resize(2, iCol - iLastCol - 1).ClearContents
                iLastCol = iCol
                resStrng = .Cells(2, iCol)
                header = .Cells(1, iCol).Value
            End If
            iCol = iCol + 1

        Loop While iCol <= .Columns.Count
        .Cells(2, iLastCol).Value = resStrng
        .Cells(1, iLastCol + 1).Resize(2, iCol - iLastCol - 1).ClearContents
        .EntireColumn.AutoFit
    End With
End Sub

Sub SortRange(rng As Range)
    With rng.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rng.Rows(1), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:=xlSortNormal

        .SetRange rng
        .header = xlYes
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Excel：将具有相似值的列合并为一个

1 个答案: