处理不同列表大小的相对范围内的序列编号

Question

我正在创建一个从几十个不同工作表构建文档的宏。它从每个工作表中提取列表（长度可能不同），并将它们放在估计页面上的表格中。每个表中的项目按顺序编号。这个序列编号在估算表的每个表格中重新开始。

我已经用更多信息更新了这个问题，因为答案清楚地表明我正在使用非标准的构建表格的方式。我已经在下面包含了完整的宏，以及一些示例输出。

这是上下文的完整宏脚本：

'declare global variables
Dim WorkingPercentage As Variant
Dim EstimateDate As Variant
Dim LastRow As Variant
Dim EstLastRow As Variant
Dim NumRows As Integer
Dim SourceRange As Range
Dim fillrange As Range
Dim est_sht As Worksheet
Dim answer As Integer
Dim InputPercentage As Integer
Dim i As Long
Dim j As Long
Dim subcat_yn As Variant
Dim subcatprice As Variant

Sub IterateSheets()

'associate worksheet variables with job categories worksheets
Set est_sht = ActiveWorkbook.Sheets("Estimate Report")
'declare other variables

Dim WshtNameCrnt As Variant
Dim WshtNames As Variant

'prompt user whether estimate sheets are completely filled out"
answer = MsgBox("Have you completed the estimate for all relevant labor categories?", vbYesNo + vbQuestion, "Populate Estimate")

If answer = vbYes Then

'prompt user for markup percentage
InputPercentage = Application.InputBox("What deposit percentage would you like to charge?", "Enter a number", , , , , , Type:=1)

'prompt user for date to be displayed on estimate
EstimateDate = Application.InputBox("What date would you like on the estimate document?  Please enter as MM/DD/YYYY.", "Date")

WorkingPercentage = InputPercentage / 100

'prompt user whether or not to include subcategory totals
subcat_yn = MsgBox("Would you like to include subtotals next to labor subcategories in the estimate?", vbYesNo, "Display labor subcategory subtotals?")

If subcat_yn = vbYes Then
  subcatprice = "y"
ElseIf subcat_yn = vbNo Then
  subcatprice = "n"
End If

'clear out estimate sheet
est_sht.Cells.Clear

'remove gridlines
est_sht.Activate
ActiveWindow.DisplayGridlines = False

'set fill color of cells FIND CORRECT COLOR CODE
'With est_sht.Cells.Interior
'        .Pattern = xlSolid
'        .PatternColorIndex = -4142
'        .ThemeColor = xlThemeColorAccent6
'        .TintAndShade = 0
'        .PatternTintAndShade = 0
'    End With

'set row height of top accent bar
est_sht.Rows("1:1").RowHeight = 10

'set width of left 2 columns
est_sht.Columns("A:A").columnwidth = 1
est_sht.Columns("B:B").columnwidth = 3

'set color of top accent bar
With est_sht.Range("A1:J1").Interior
.Color = vbBlack
End With

'set row 2 height
est_sht.Rows("2:2").RowHeight = 16.5

'set row 3 height
est_sht.Rows("3:3").RowHeight = 80

'set text formatting
With est_sht.Rows("3:3").Font
        .Name = "Arial"
        .Size = 15
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0.349986266670736
        .ThemeFont = xlThemeFontMajor
    End With
est_sht.Rows("3:3").Font.Bold = True

'Date stamp the estimate based on form input
est_sht.Cells(3, 3).Value = EstimateDate

'title the estimate
est_sht.Cells(3, 5).Value = "Cost Estimate"

'Insert header row text'
est_sht.Cells(4, 3).Value = "PROJECT TASKS"
est_sht.Cells(4, 4).Value = "Cost Estimate"
est_sht.Cells(4, 5).FormulaR1C1 = InputPercentage & "% Deposit"
est_sht.Cells(4, 6).Value = "Current Costs"

'format header row
With est_sht.Rows("4:4")
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
With est_sht.Rows("4:4").Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0.349986266670736
        .ThemeFont = xlThemeFontMajor
    End With

est_sht.Rows("4:4").Font.Bold = True

'create variant array of worksheets
WshtNames = Array("permits", "project management", "in progress design", "site prep", "services on site", "layout", "concrete", "water management", "framing", "roofing and sheet metal", "electrical", "plumbing", "HVAC", "windows and doors", "exterior finishes", "insulation", "drywall", "painting", "cabinetry", "countertops", "interior finishes", "flooring", "tile", "deck garden", "landscaping", "appliances", "punchlist", "add-ons", "contingency")

'loop through worksheets
  For WshtNameCrnt = LBound(WshtNames) To UBound(WshtNames)
     With Worksheets(WshtNames(WshtNameCrnt))

        'find last row on estimate page
        With est_sht
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                EstLastRow = .Cells.Find(What:="*", _
                            After:=.Range("B1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
            Else
                EstLastRow = 1
            End If
        End With

        'format sub-header
        est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + 2, 6)).Font.Bold = True
        est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + 2, 6)).NumberFormat = "$#,##0.00"
        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + 2, 6)).Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0.349986266670736
        .ThemeFont = xlThemeFontMajor
        End With

        'Find last row on current worksheet
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                LastRow = .Cells.Find(What:="*", _
                            After:=.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
            Else
                LastRow = 1
            End If

        'count the number of rows filled with sub-categories'
        NumRows = LastRow - 4

        'pull sub-categories from current worksheet tab to estimate page
        est_sht.Range(est_sht.Cells(EstLastRow + 3, 3), est_sht.Cells(NumRows + EstLastRow + 3, 3)).Value = .Range(.Cells(4, 1), .Cells(LastRow, 1)).Value

        'add sheet name to table
        est_sht.Cells(EstLastRow + 2, 3).Value = .Name

        'add sequential numbers next to labor categories on estimate page
        'handle the case of a single subcategory
        If NumRows = 1 Then
            est_sht.Cells(EstLastRow + 3, 2).Value = 1
        ElseIf NumRows > 1 Then
            est_sht.Cells(EstLastRow + 3, 2).Value = 1
            est_sht.Range(est_sht.Cells(EstLastRow + 4, 2), est_sht.Cells(EstLastRow + NumRows + 3, 2)).FormulaR1C1 = "=R[-1]C+1"
        End If

        'set black fill color in sequential numbers sidebar
        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 2), est_sht.Cells(EstLastRow + NumRows + 3, 2)).Interior
        .Color = vbBlack
        End With
        'format text of sequential numbers
        With est_sht.Range(est_sht.Cells(EstLastRow + 3, 2), est_sht.Cells(EstLastRow + NumRows + 3, 2)).Font
            .Name = "Arial"
            .Size = 9
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        'format sequential numbers bold
        est_sht.Range(est_sht.Cells(EstLastRow + 3, 2), est_sht.Cells(EstLastRow + NumRows + 3, 2)).Font.Bold = True

        'copy cost subtotal to estimate page
        est_sht.Cells(EstLastRow + 2, 4).Value = .Range("G1").Value

        'initiate do while loop for labor subcategory subtotals
        Do
            'pull subtotals from subcategory items to estimate
            est_sht.Range(est_sht.Cells(EstLastRow + 3, 4), est_sht.Cells(NumRows + EstLastRow + 3, 4)).Value = .Range(.Cells(4, 7), .Cells(LastRow, 7)).Value
            'set formula for deposit numbers on estimate sheet
            'populate deposit formula in estimate page
            est_sht.Range(est_sht.Cells(EstLastRow + 3, 5), est_sht.Cells(NumRows + EstLastRow + 3, 5)).FormulaR1C1 = "=RC[-1]*" & WorkingPercentage
            'populate sum formula in "current costs" for labor category
            'set formula for totals on estimate sheet
            est_sht.Range(est_sht.Cells(EstLastRow + 3, 6), est_sht.Cells(NumRows + EstLastRow + 3, 6)).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
            'set text formatting of subtotals, deposits, and totals
            est_sht.Range(est_sht.Cells(EstLastRow + 2, 4), est_sht.Cells(NumRows + EstLastRow + 3, 6)).NumberFormat = "$#,##0.00"
            With est_sht.Range(est_sht.Cells(EstLastRow + 2, 4), est_sht.Cells(NumRows + EstLastRow + 3, 6)).Font
            .Name = "Arial"
            .Size = 9
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0.349986266670736
            .ThemeFont = xlThemeFontMajor
            End With
        Loop While subcat_yn = y And Not subcat_yn = n

        'populate deposit formula in estimate page
        est_sht.Cells(EstLastRow + 2, 5).FormulaR1C1 = "=RC[-1]*" & WorkingPercentage
        'populate sum formula in "current costs" for labor category
        est_sht.Cells(EstLastRow + 2, 6).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"

        'format sub-category items text
        With est_sht.Range(est_sht.Cells(EstLastRow + 3, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0.349986266670736
        .ThemeFont = xlThemeFontMajor
        End With

        'format table around sub-category items and costs
        est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlDiagonalDown).LineStyle = xlNone
        est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlDiagonalUp).LineStyle = xlNone

        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        est_sht.Range(est_sht.Cells(EstLastRow + 2, 3), est_sht.Cells(EstLastRow + NumRows + 3, 6)).Borders(xlInsideHorizontal).LineStyle = xlNone

        'repaint screen as macro works and scroll with the active line
        est_sht.Activate
        ActiveWindow.ScrollRow = EstLastRow

      End With
  Next WshtNameCrnt

'this else statement refers to the msgbox statement that initializes the macro
Else
    Exit Sub
'end of main if/else loop, and end of sub'
End If

'set typeface for entire estimate sheet
est_sht.Cells.Font.Name = "Arial"

'autofit columns in entire estimate sheet
est_sht.Cells.EntireColumn.AutoFit

'remove row column under header
est_sht.Rows("5:5").Delete Shift:=xlUp

est_sht.Activate

End Sub

以下是我目前的编号代码：

If NumRows = 1 Then
    est_sht.Cells(EstLastRow + 3, 2).Value = 1

ElseIf NumRows > 1 Then
    est_sht.Cells(EstLastRow + 3, 2).Value = 1
    est_sht.Range(est_sht.Cells(EstLastRow + 4, 2), est_sht.Cells(EstLastRow + NumRows + 3, 2)).FormulaR1C1 = "=R[-1]C+1"

End If

这适用于包含三个或更多项目的表格，但是包含1个项目的表格没有数字，而包含2个项目的表格只有第一个项目编号，第二个项目旁边没有数字值。这是我得到的输出的一个例子：

我尝试了其他几种方法，包括将ElseIf语句用于2项列表：

If NumRows = 1 Then
    est_sht.Cells(EstLastRow + 3, 2).Value = 1

ElseIf NumRows = 2 Then
    est_sht.Cells(EstLastRow + 3, 2).Value = 1
    est_sht.Cells(EstLastRow + 4, 2).Value = 2

ElseIf NumRows > 2 Then
    est_sht.Cells(EstLastRow + 3, 2).Value = 1
    est_sht.Range(est_sht.Cells(EstLastRow + 4, 2), est_sht.Cells(EstLastRow + NumRows + 3, 2)).FormulaR1C1 = "=R[-1]C+1"

End If 

但这会导致同样的问题。

Answer 1

工作表中编号列表的版本：

具有以下主要假设：

1）编号范围的起始行为B6

2）标题部分总是以粗体显示，例如干墙

代码：

Option Explicit

Public Sub AddRowNumsToListItems()

    Dim wb As Workbook
    Dim est_sht As Worksheet
    Dim numRange As Range
    Dim lastRow As Long                          'lastRow in col C
    Dim currRow As Range

    Set wb = ThisWorkbook
    Set est_sht = wb.Worksheets("Sheet1")        'change as appropriate

    lastRow = est_sht.Cells(est_sht.Rows.Count, "C").End(xlUp).Row

    Set numRange = est_sht.Range("C5:C" & lastRow)

    Dim counter As Long

    counter = 0

    For Each currRow In numRange.Rows            'loop column C

        If Not currRow.Font.Bold And Not IsEmpty(currRow) Then
            counter = counter + 1
            currRow.Offset(, -1) = counter 'adjacent column add number
        Else
           counter = 0
        End If

    Next currRow

End Sub

Excel表格版：

有以下假设：

1. 数据设置为Excel表，每个表中都有一个名为RowNum的列，用于保存表的顺序行编号
2. 每个表的行编号从一开始
3. est_sht中的每个表格都会添加此编号

本质上，有一个函数ListTables收集工作表est_sht中的所有表名，并将它们存储在数组tableArr中。

有一个过程AddRowNumsToTables调用此函数并循环表名称，将活动单元格公式"=ROW()-ROW(" & tableArr(currTable) & ")+1"添加到列RowNum，该列按顺序对每个表中的行进行编号。

如果这与你所追求的相近，请告诉我。

在标准模块中输入以下内容：

Private Sub AddRowNumsToTables()

    Dim wb As Workbook
    Dim est_sht As Worksheet

    Set wb = ThisWorkbook
    Set est_sht = wb.Worksheets("Sheet1")

    Dim tableArr() As String

    tableArr = ListTables

    Dim currTable As Long

    For currTable = LBound(tableArr) To UBound(tableArr)

        With est_sht.ListObjects(tableArr(currTable))

            est_sht.Range(tableArr(currTable) & "[RowNum]").FormulaR1C1 = "=ROW()-ROW(" & tableArr(currTable) & ")+1"

        End With

    Next currTable
End Sub

Private Function ListTables() As String()

    Dim wb As Workbook
    Dim est_sht As Worksheet
    Dim tbl As ListObject
    Dim tableArr() As String
    ReDim tableArr(0 To 100)
    Dim counter As Long

    Set wb = ThisWorkbook
    Set est_sht = wb.Worksheets("Sheet1")
    counter = 0

    For Each tbl In est_sht.ListObjects
        tableArr(counter) = tbl.Name
        counter = counter + 1
    Next tbl

    ReDim Preserve tableArr(0 To counter - 1)

    ListTables = tableArr

End Function