Excel VBA 如果单元格匹配第一个字符，则插入行

Question

所以我有一个大数据集，我想根据第一列中的信息是否在一定程度上匹配来组合行。 我想知道是否有一个宏可以做到这一点。 下面我包含了一个类似的简化数据集的图像。 我假设宏会在新工作表中创建新表或在现有数据下方插入一行，但我不确定。 关于这个问题的任何帮助或提示都会非常有帮助。

示例数据集：

输出：

Answer 1

添加一列，提取第一列的前几个字符。 然后创建一个数据透视表，其中包含行中的新列和值区域中的其他列。 不需要VBA。

Answer 2

您可以尝试以下（注释）代码：

Option Explicit

Sub main()
    Dim cell As Range, cell2 As Range

    With Worksheets("experiment").Range("A1").CurrentRegion '<--| reference data worksheet(change "experiment" to its actual name) cell "A1" contiguous range column "A"
        .Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes '<--| sort it by "experiment" column to have "smaller" names at the top
        For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1) '<--| loop through its 1st column cells skipping header row
            If cell.Value <> "" Then '<--| if current cell isn't blank (also as a result of subsequent operations)
                .AutoFilter Field:=1, Criteria1:="*" & cell.Value & "*" '<--| filter on referenced column to get cell "containing" current cell content
                If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 2 Then '<--| if more than 2 rows has been foun: header row gets always filtered so to have at least 2 rows to consolidate we must filter at least 3
                    With .Offset(1).Resize(.Rows.Count - 1) '<--| reference filtered rows skipping header row
                        For Each cell2 In .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible).Areas(1).Rows(1).Cells '<--| loop through 1st filtered row cells skipping 1st column ("experiment")
                            cell2.Value = WorksheetFunction.Subtotal(9, cell2.EntireColumn) '<--| update their content to the sum of filtered cells in corresponding column
                        Next cell2
                        With .Resize(, 1).SpecialCells(xlCellTypeVisible) '<--| reference filtered rows 1st column ("experiment") cells
                            .Value = .Cells(1, 1) '<--| have them share the same name
                        End With
                        .RemoveDuplicates Columns:=Array(1), Header:=xlNo '<--| remove duplicates, thus leaving the 1st filtered row with totals
                    End With
                End If
            End If
        Next cell
        .Parent.AutoFilterMode = False '<--| show all rows back
    End With
End Sub