将列中的相似名称分组，并将偏移量与该分组范围的总和相加

Question

我有一个我在excel中运行的宏。我在“D”栏中有公司名称。列的名称是安全描述（长1）。我试图将类似的声音名称或相同的名称分组，并在组之间插入一行。该宏运行良好，但目前分组不准确。我的代码如下：

Dim RowCount As Integer
Dim n As Integer

RowCount = Range(Range("A15000").End(xlUp), "A7").Rows.Count

Range("D6").Select

If Selection <> "" Then
    For n = 1 To RowCount + 1
        Selection.Offset(1, 0).Select
        If Selection <> Selection.Offset(-1, 0) Then
            If Selection.Offset(-1, 0) Like "* Security Description (Long 1)*" Then
                Selection.EntireRow.Insert shift:=xlDown
                Selection.EntireRow.Insert shift:=xlDown


                Selection.Offset(2, 0).Select
            Else
                Selection.EntireRow.Insert shift:=xlDown
                Selection.EntireRow.Insert shift:=xlDown



                If Selection.Offset(-2) = vbNullString Then
                    Selection.Offset(0, 2) = Selection.Offset(-1, 2)
                Else
                    Selection.Offset(0, 3) = Application.WorksheetFunction.Sum(Range(Selection.Offset(-1, 3), Selection.Offset(-1, 3).End(xlUp)))
                End If

                Selection.Offset(0, 3).Font.Bold = True

                With Selection.Offset(0, 3).Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
                With Selection.Offset(0, 3).Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With

            Selection.Offset(3, 0).Select
            End If
        End If
    Next n
End If

Range("A15000").End(xlUp).Clear

Answer 1

在我们对分组进行正确处理之前，别无其他事情。

在大多数示例中，您在组标识符后面有一个空格。所以在“史密斯简”中，“史密斯”是团体ID。唯一的例外是“Abbey1”，它是“修道院”组的一部分，即使“修道院”和“1”之间没有空间。这可能是打字错误，所以暂时我忽略了“Abbey1”。如果这是一个错误，我们可以稍后纠正。

我写了两个宏：GetGroupId和TestGetGroupId。

注意：如果您不确定如何做某事，请单独试验该问题。只有当您的日常工作满意时才能满足您的要求。

宏GetGroupId将Name作为参数，如果没有空格，则将所有内容返回到第一个空格或整个名称。如果“Abbey1”是“Abbey”组的一部分，这个宏将需要增强，但让我们先尝试简单版本。

宏TestGetGroupId为宏GetGroupId提供了一个测试平台。

最好按名称引用工作表，而不是假设活动工作表是必需的工作表。我为您的数据工作表使用了名称“Name”。宏需要一个工作表，它可以输出诊断信息。我已将此工作表命名为“Test”。如果名称“名称”错误或名称“测试”因您已使用该名称而无法接受，请更改它们。搜索“##########”，您将在宏TestGetGroupId中的变量定义下找到它。这是定义这些工作表名称的地方。

对于我的测试，我创建了包含以下内容的工作表“Name”：

如果我误解了您的数据，请告诉我。

宏宏TestGetGroupId的输出是：

使用的最后一列是“H”，因为ColTestMax的值为8.（列“H”相当于第8列）。如果你有短名称，你可以增加ColTestMax的值，并且仍然拥有屏幕上的所有列。

针对您的姓名运行宏TestGetGroupId。工作表“测试”是否显示正确分组？告诉我是否有任何错误分组。不要过分担心这些宏;我将用最终宏提供更多解释。

Option Explicit
Sub TestGetGroupId()

  ' Group names using GetGroupId() and output diagnostics to
  ' check that grouping is correct.

  Dim ColTestCrnt As Long
  Dim GroupIdCrnt As String
  Dim GroupIdCrntGroup As String
  Dim NameCrnt As String
  Dim RowNameCrnt As Long
  Dim RowNameLast As Long
  Dim RowTestCrnt As Long
  Dim WshtName As Worksheet
  Dim WshtTest As Worksheet

  Const ColNameName As Long = 4         ' Column D
  Const ColTestGroupId As Long = 1
  Const ColTestRowFirst As Long = 2
  Const ColTestRowLast As Long = 3
  Const ColTestNameFirst As Long = 4    ' This column must come after GroupId,
                                        ' RowFirst and RowLast
  ' ColTestMax controls the number of of names on a row of worksheet "Test"
  ' If names are short you might wish to increase ColTestMax. If names are long
  ' you might wish to reduce ColTestMax.
  Const ColTestMax As Long = 8
  Const RowNameDataFirst As Long = 7

  Application.ScreenUpdating = False

  ' * ########## Replace "Name" with your name for the worksheet containing
  '              names.
  Set WshtName = Worksheets("Name")
  ' * ########## Replace "Test" with name of your choice if you already have a
  '              worksheet named "Test".
  Set WshtTest = Worksheets("Test")

  With WshtName
    RowNameLast = .Cells(Rows.Count, ColNameName).End(xlUp).Row  ' Last used row of name column
    NameCrnt = .Cells(RowNameDataFirst, ColNameName).Value       ' First name
    GroupIdCrntGroup = GetGroupId(NameCrnt)                  ' First Group Id
    RowNameCrnt = RowNameDataFirst
  End With

  With WshtTest
    .Cells.EntireRow.Delete                                  ' Clear any existing data
    ' Build header line
    .Cells(1, ColTestGroupId).Value = "Group Id"
    .Cells(1, ColTestRowFirst).Value = "Row First"
    .Cells(1, ColTestRowLast).Value = "Row Last"
    .Cells(1, ColTestNameFirst).Value = "Names within Group -->"
    .Range(.Cells(1, ColTestNameFirst), .Cells(1, ColTestMax)).Merge
    .Range(.Cells(1, 1), .Cells(1, ColTestNameFirst)).Font.Bold = True
    RowTestCrnt = 2
    ' Start first row for first Group Id
    .Cells(RowTestCrnt, ColTestGroupId).Value = GroupIdCrntGroup
    .Cells(RowTestCrnt, ColTestRowFirst).Value = RowNameCrnt
    ColTestCrnt = ColTestNameFirst
    .Cells(RowTestCrnt, ColTestCrnt).Value = NameCrnt
  End With

  RowNameCrnt = RowNameDataFirst + 1    ' RowNameDataFirst has already been processed

  ' A For-Next-Loop would probably be more convenient but within the desired
  ' macro rows will be inserted so RowNameLast will increase. The end value of a
  ' For-Next-Loop cannot be modified within the loop so a Do-Loop must be used.
  ' Use a Do-Loop here to be consistent.
  Do While RowNameCrnt <= RowNameLast
    NameCrnt = WshtName.Cells(RowNameCrnt, ColNameName).Value
    GroupIdCrnt = GetGroupId(NameCrnt)
    If GroupIdCrnt = GroupIdCrntGroup Then
      ' Have another name row within current group. Add name to worksheet "Test"
      ColTestCrnt = ColTestCrnt + 1
      If ColTestCrnt > ColTestMax Then
        ' Current row of worksheet "Test" is full.  Advance to next row.
        ColTestCrnt = ColTestNameFirst
        RowTestCrnt = RowTestCrnt + 1
      End If
      WshtTest.Cells(RowTestCrnt, ColTestCrnt).Value = NameCrnt
    Else
      ' Have first row of next group. Finish off last group and start new.
      With WshtTest
        .Cells(RowTestCrnt, ColTestRowLast).Value = RowNameCrnt - 1
        RowTestCrnt = RowTestCrnt + 1
        GroupIdCrntGroup = GroupIdCrnt
        .Cells(RowTestCrnt, ColTestGroupId).Value = GroupIdCrntGroup
        .Cells(RowTestCrnt, ColTestRowFirst).Value = RowNameCrnt
        ColTestCrnt = ColTestNameFirst
        .Cells(RowTestCrnt, ColTestCrnt).Value = NameCrnt
      End With
    End If
    RowNameCrnt = RowNameCrnt + 1
  Loop

  ' Finish off last group
  With WshtTest
    .Cells(RowTestCrnt, ColTestRowLast).Value = RowNameCrnt - 1
    .Columns.AutoFit
  End With

End Sub
Function GetGroupId(ByVal Name As String) As String

  Dim PosSpace As Long

  PosSpace = InStr(1, Name, " ")

  If PosSpace = 0 Then
    ' No spaces within Name
    GetGroupId = Name
  Else
    ' GroupId is anything before space
    GetGroupId = Mid(Name, 1, PosSpace - 1)
  End If

End Function

第2部分

通过所有的选择和偏移，我努力确定你在尝试什么。下面的代码是我认为你正在尝试的版本。

确保在运行此宏之前保存了数据。

宏中有很多信息和建议，但关于我使用的语句没有太多信息。如有必要，请回答问题，但通过查看我的陈述，您可以更快地找到自己的技能。

我发现使用插入线周围的边框与小组非常混乱。我已经离开了原始代码，但已将其评论出来。我使用颜色突出显示插入的行。

我相信我已经为您提供了足够的信息，可以根据您的具体要求调整宏。

Option Explicit
Sub Group()

  ' Identify groups of names and separate then by a blank
  ' row containing the total of column "G" for the group.

  ' # This macro needs access to GetGroupId.  If GetGroupId is not in the same
  '   module, add "Public" to the beginning of the definition of GetGroupId:
  '      Public Function GetGroupId(ByVal Name As String) As String

  ' # Long is better than Integer as a VBA data type on modern computers
  Dim GroupGrandTotal As Long
  Dim GroupIdCrnt As String
  Dim GroupIdCrntGroup As String
  Dim NameCrnt As String
  ' # Please avoid variable names like "n".  It does not really matter with
  '   a small macro but with bigger macros having meaningless names makes
  '   coding and maintenance more difficult.  I have a system so I can look
  '   at a macro I wrote years ago and know what all the variables are. This
  '   can be a big help. You may not like my system which is fine; develop
  '   your own system.
  Dim RowNameCrnt As Long
  Dim RowNameLast As Long
  Dim WshtName As Worksheet

  ' # Constants are just the same as literals except:
  '     * They make your code easier to read.
  '     * They make updating your code easier if, for example, a column moves.
  Const ColNameName As Long = 4       ' Column D
  Const ColNameTotal As Long = 7      ' Column G
  ' * ########## Define range for borders. Adjust as necessary.
  Const ColNameFirst As Long = 1      ' Column A
  Const ColNameLast As Long = 8       ' Column H
  Const RowNameDataFirst As Long = 7

  ' Without this every insert causes the screen to be repainted.
  ' This can extend the duration of a macro significantly.
  Application.ScreenUpdating = False

  ' # Only one worksheet is accessed by this macro.  So I have could :
  '      With Worksheets("Name")
  '   at the top instead of
  '      With WshtName
  ' # Note that "With Worksheets("Name")" is a slow command because the
  '   interpreter has to look "Name" in the collection of worksheets.  If
  '   you are switching between worksheets, WshtName can be significantly
  '   faster than Worksheets("Name").
  ' # By not specifying a worksheet, you are assuming the active worksheet is
  '   the correct worksheet.  If you only have one worksheet this may be
  '   correct.  However, if there are multiple worksheets, you are relying on
  '   the user selecting the correct worksheet before starting the macro.
  '   It is always better to be explicit.
  ' # ########## Replace "Name" with your name for the worksheet containing
  '              names.
  Set WshtName = Worksheets("Name")

  With WshtName
    ' # I do not find your RowCount obvious.  I find specifying the first row
    '   as a constant, finding the last row and using RowCrnt (current row) as
    '   the loop variable easier to understand.
    RowNameLast = .Cells(Rows.Count, ColNameName).End(xlUp).Row  ' Last used row of name column
    NameCrnt = .Cells(RowNameDataFirst, ColNameName).Value       ' First name
    GroupGrandTotal = .Cells(RowNameDataFirst, ColNameTotal).Value
    GroupIdCrntGroup = GetGroupId(NameCrnt)                  ' First Group Id
    RowNameCrnt = RowNameDataFirst

    ' # Avoid Select. This is a slow command and it can make your code very
    '   obscure particularly if you use Offset on a constantly changing
    '   selection.

    RowNameCrnt = RowNameDataFirst + 1    ' RowNameDataFirst has already been processed

    ' # I would normally use a For-Next-Loop but the insertion of rows means the
    '   value of RowNameLast will increase. The end value of a For-Next-Loop cannot be
    '   modified within the loop so a Do-Loop must be used.
    '   Use a Do-Loop here to be consistent.
    Do While RowNameCrnt <= RowNameLast
      NameCrnt = WshtName.Cells(RowNameCrnt, ColNameName).Value
      GroupIdCrnt = GetGroupId(NameCrnt)
      If GroupIdCrnt = GroupIdCrntGroup Then
        ' Have another name row within current group. Add its total to Grand total
        GroupGrandTotal = GroupGrandTotal + .Cells(RowNameCrnt, ColNameTotal).Value
      Else
        ' Have first row of next group. Finish off last group
        .Rows(RowNameCrnt).Insert
        RowNameLast = RowNameLast + 1
        ' RowNameCrnt is the number of the new row.
        ' I tried setting borders but I found the effect messy when their were small
        ' group.  I thought a coloured row was more effective
        '' Set borders
        'With .Range(.Cells(RowNameCrnt, ColNameFirst), .Cells(RowNameCrnt, ColNameLast))
        '  With .Borders(xlEdgeTop)
        '    .LineStyle = xlContinuous
        '    .Weight = xlThin
        '  End With
        '  With .Borders(xlEdgeBottom)
        '    .LineStyle = xlDouble
        '    .Weight = xlThick
        '  End With
        'End With
        With .Range(.Cells(RowNameCrnt, ColNameFirst), .Cells(RowNameCrnt, ColNameLast))
          .Interior.Color = RGB(255, 255, 153)      ' Light yellow
        End With
        ' Insert grand total for group
        .Cells(RowNameCrnt, ColNameTotal).Value = GroupGrandTotal
        ' Start new group
        RowNameCrnt = RowNameCrnt + 1     ' First row of next group
        GroupIdCrntGroup = GroupIdCrnt
        GroupGrandTotal = .Cells(RowNameCrnt, ColNameTotal).Value
      End If
      RowNameCrnt = RowNameCrnt + 1
    Loop

    ' Finish off last group
    RowNameCrnt = RowNameLast + 1
    '' Set borders
    'With .Range(.Cells(RowNameCrnt, ColNameFirst), .Cells(RowNameCrnt, ColNameLast))
    '  With .Borders(xlEdgeTop)
    '    .LineStyle = xlContinuous
    '    .Weight = xlThin
    '  End With
    '  With .Borders(xlEdgeBottom)
    '    .LineStyle = xlDouble
    '    .Weight = xlThick
    '  End With
    'End With
    With .Range(.Cells(RowNameCrnt, ColNameFirst), .Cells(RowNameCrnt, ColNameLast))
      .Interior.Color = RGB(255, 255, 153)      ' Light yellow
    End With
    ' Insert grand total for group
    .Cells(RowNameCrnt, ColNameTotal).Value = GroupGrandTotal

  End With  ' WshtName

End Sub