处理不同列表大小的相对范围的顺序编号
我正在创build一个从几十个不同的工作表构build一个文档的macros。 它从每张表中拉出列表（可能长度不同），并将它们放在估计页面的表格中。 每个表中的项目都按顺序编号。 估算表上的每个表格中都会重新编号。
我已经用更多的信息更新了这个问题，因为答案已经清楚地表明我正在使用非标准的方式来build立表格。 我已经包含了下面的全部macros，以及一些示例输出。
以下是上下文的完整macros脚本：
'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
这适用于有三个或更多项目的表格，但具有一个项目的表格没有数字，而具有两个项目的表格只有第一个项目编号，第二个项目旁边没有数字值。 这里是我得到的输出的一个例子：
我已经尝试了一些其他的方法，包括使用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
但是这会导致同样的问题。
工作表中编号列表的版本 ：
主要假设如下：
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表版本 ：
有以下假设：
- 数据设置为Excel表，并且在每个表中都有一个名为RowNum的列，该列包含表的顺序行编号
- 行编号从每个表开始
-
est_sht每个表est_sht将添加此编号
本质上，有一个函数ListTables ，它收集工作表ListTables中的所有表名，并将它们存储在一个数组tableArr 。
有一个过程AddRowNumsToTables调用这个函数并循环添加一个活动的单元格公式"=ROW()-ROW(" & tableArr(currTable) & ")+1"表。
让我知道这是否接近你以后的。
在一个标准模块中放置如下：
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