Grouping similar names in a column and offset to sum that grouped range

Question

I have a macro I am running in excel. I have companies’ names in column “D”. The name of the column is Security Description (Long 1). I am trying to group similar sounding names or identical names and insert a row between the groups. The macro is working well but grouping is not accurate right now. My code is below:

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

There is no point fussing with anything else until we have the grouping correct.

In most of your examples you have a space after the group identifier. So in “Smith Jane”, “Smith” is the group id. The exception is “Abbey1” which is part of the “Abbey” group even though there is no space between “Abbey” and “1”. This may be a typing error so for the moment I have ignored “Abbey1”. If that was a mistake, we can correct it later.

I have written two macro: GetGroupId and TestGetGroupId.

Note: If you are not sure how to do something, experiment with that issue in isolation. Only when you have routines that work to your entire satisfaction should you look at the rest of your requirement.

Macro GetGroupId takes Name as a parameter and returns everything up to the first space or the entire name if there is no space. If “Abbey1” is a part of the “Abbey” group, this macro will need enhancement but let us try the simple version first.

Macro TestGetGroupId provides a test bed for Macro GetGroupId.

It is best to reference worksheets by name rather than assume the active worksheet is the one required. I have used the name “Name” for your data worksheet. The macro needs a worksheet to which it can output diagnostic information. I have named this worksheet “Test”. If the name “Name” is wrong or if the name “Test” is unacceptable because you already use that name, change them. Search for “##########” which you will find just under the variable definitions in Macro TestGetGroupId. This is where these worksheet names are defined.

For my test, I created worksheet “Name” containing:

If I misunderstood your data, let me know.

The output from macro Macro TestGetGroupId is:

The last column used is “H” because ColTestMax has a value of 8. (Column “H” is equivalent to Column 8). If you have short names you could increase the value of ColTestMax and still have all the columns on the screen.

Run Macro TestGetGroupId against your names. Does worksheet “Test” show them being grouped correctly? Tell me if any are mis-grouped. Don't worry too much about these macros; I will provide more explanation with the final macro.

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

Part 2

With all the Selects and Offsets, I struggled to identify what you were attempting. The code below is my version of what I think you are attempting.

Make sure you have saved your data before running this macro.

There is a lot of information and advice within the macro but not much information about the statements I use. Come back with questions if necessary but the more you can work out for yourself by looking up my statements the faster you will develop your own skills.

I found using borders around the inserted line very messy with small groups. I have left my original code but have commented it out. I use colour to highlight the inserted line.

I believe I have provided enough information for you to adjust my macro to your exact requirements.

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