将列中的相似名称分组并偏移以对该分组范围求和
Grouping similar names in a column and offset to sum that grouped range
我有一个宏我是 运行 在 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
在我们正确分组之前,没有必要为其他事情大惊小怪。
在大多数示例中,组标识符后都有一个 space。所以在“Smith Jane”中,“Smith”是组id。例外是“Abbey1”,它是“Abbey”组的一部分,即使“Abbey”和“1”之间没有 space。这可能是打字错误,所以目前我忽略了“Abbey1”。如果那是一个错误,我们可以稍后更正。
我写了两个宏:GetGroupId
和TestGetGroupId
。
注意:如果您不确定如何做某事,请单独试验该问题。只有当您拥有令您完全满意的例程时,您才应该查看其余的要求。
宏 GetGroupId
将 Name
作为参数,returns 直到第一个 space 或整个名称(如果没有 space)的所有内容。如果“Abbey1”是“Abbey”组的一部分,这个宏将需要增强,但让我们先尝试简单版本。
Macro TestGetGroupId
为 Macro GetGroupId
.
提供了一个测试平台
最好按名称引用工作表,而不是假定活动工作表就是必需的。我为您的数据工作表使用了名称“名称”。宏需要一个工作表,它可以向其中输出诊断信息。我将此工作表命名为“测试”。如果名称“Name”错误或名称“Test”不可接受,因为您已经在使用该名称,请更改它们。搜索“##########”,您将在宏 TestGetGroupId
的变量定义下方找到它。这是定义这些工作表名称的地方。
为了测试,我创建了工作表“名称”,其中包含:
如果我误解了你的数据,请告诉我。
宏 Macro 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
我有一个宏我是 运行 在 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
在我们正确分组之前,没有必要为其他事情大惊小怪。
在大多数示例中,组标识符后都有一个 space。所以在“Smith Jane”中,“Smith”是组id。例外是“Abbey1”,它是“Abbey”组的一部分,即使“Abbey”和“1”之间没有 space。这可能是打字错误,所以目前我忽略了“Abbey1”。如果那是一个错误,我们可以稍后更正。
我写了两个宏:GetGroupId
和TestGetGroupId
。
注意:如果您不确定如何做某事,请单独试验该问题。只有当您拥有令您完全满意的例程时,您才应该查看其余的要求。
宏 GetGroupId
将 Name
作为参数,returns 直到第一个 space 或整个名称(如果没有 space)的所有内容。如果“Abbey1”是“Abbey”组的一部分,这个宏将需要增强,但让我们先尝试简单版本。
Macro TestGetGroupId
为 Macro GetGroupId
.
最好按名称引用工作表,而不是假定活动工作表就是必需的。我为您的数据工作表使用了名称“名称”。宏需要一个工作表,它可以向其中输出诊断信息。我将此工作表命名为“测试”。如果名称“Name”错误或名称“Test”不可接受,因为您已经在使用该名称,请更改它们。搜索“##########”,您将在宏 TestGetGroupId
的变量定义下方找到它。这是定义这些工作表名称的地方。
为了测试,我创建了工作表“名称”,其中包含:
如果我误解了你的数据,请告诉我。
宏 Macro 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