Excel宏运行次数多单元格计数器开发及表格列关联需求

需求说明 #

• 首次运行宏时在A1写入1，后续每次运行依次在B1、C1...写入递增数字，计数不被覆盖
• 每次生成表格时，需将最新计数同步到表格的第一列所有数据行
• 当前已实现单个单元格计数和表格生成，但多单元格横向计数、计数与表格关联逻辑未完成

现有代码 #

Sub GenerateSupplyChain()

'Range("A18").Value = Range("A18").Value + 1     Works, but in same cell, need to have it count downwards

Dim MySheet As String, ws As Worksheet
MySheet = Sheets("Instructions").Range("T1").Value
Set ws = Sheets(MySheet)
    
    Const COL_KEY = "O" ' used to determine the last row
    Const FIRST_ROW = 5
    Const HEADER_RNG = "D2:AS2" ' source of header
    Const BASE_SHT = "Base Data"
    Dim i As Variant
    i = InputBox("How many DFSP's in this Supply Chain?", "Enter Quantity")
    If Not IsNumeric(i) Then
        MsgBox "Please input a number.", vbCritical
        Exit Sub
    End If
    If i < 1 Then Exit Sub
    
    Dim oSht As Worksheet, LastRow As Long
    Set oSht = Sheets(MySheet)
    LastRow = oSht.Cells(oSht.Rows.Count, COL_KEY).End(xlUp).Row
    With oSht.Cells(LastRow, COL_KEY)
        If Len(.Value) > 0 Or (Not .ListObject Is Nothing) Then
            LastRow = LastRow + 2
        End If
        If LastRow < FIRST_ROW Then LastRow = FIRST_ROW
    End With
    Dim tabRng As Range, headerRng As Range, objtable As ListObject
    Set headerRng = Sheets("BASE Data").Range(HEADER_RNG)
    Set tabRng = oSht.Cells(LastRow, COL_KEY).Resize(i + 1, headerRng.Columns.Count)
    Set objtable = Worksheets(MySheet).ListObjects.Add(xlSrcRange, tabRng, , xlYes)
    objtable.HeaderRowRange.Value = headerRng.Value
    objtable.ShowTotals = True
    objtable.TableStyle = "TableStyleLight1"
    
  ' objtable.DataBodyRange.Cells(1, 1).Formula = _   Doesnt work
       ' "=A18"
    'objtable.DataBodyRange(1, 1).FillDown (Offset - 1)     doestn work
    
   ' Set rngFormula = tblrng.Offset(1, LastRow - 1).Resize(rowData - 1, 1)  doesnt work
    'rngFormula.FillDown

    
    objtable.DataBodyRange.Cells(1, 6).Formula = _
    "=VLOOKUP([@[" & objtable.HeaderRowRange.Cells(1, 1).Value & "]],'BASE Data'!A:N,3,FALSE)"
        objtable.DataBodyRange.Cells(1, 7).Formula = _
    "=VLOOKUP([@[" & objtable.HeaderRowRange.Cells(1, 1).Value & "]],'BASE Data'!A:N,3,FALSE)"
        objtable.DataBodyRange.Cells(1, 8).Formula = _
    "=VLOOKUP([@[" & objtable.HeaderRowRange.Cells(1, 1).Value & "]],'BASE Data'!A:N,3,FALSE)"
    
End Sub

修改方案 #

1. 新增横向计数逻辑 #

在宏开头、Set ws = Sheets(MySheet)之后添加以下代码，实现第一行横向递增计数：

' 运行次数横向计数逻辑
Dim countCell As Range
Dim currentCount As Integer

' 查找第一行第一个空单元格
Set countCell = ws.Range("1:1").Find(What:="", LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If countCell Is Nothing Then
    MsgBox "第一行已无空单元格，无法记录运行计数", vbExclamation
    Exit Sub
End If

' 计算当前运行次数
currentCount = ws.Range("1:1").Cells(1, ws.Columns.Count).End(xlToLeft).Column
' 处理第一行完全为空的情况
If currentCount = 1 And ws.Range("A1").Value = "" Then
    currentCount = 0
End If
currentCount = currentCount + 1
' 写入计数
countCell.Value = currentCount

2. 同步计数到表格第一列 #

在生成表格的代码段后，添加以下代码，将最新计数赋值给表格第一列所有数据行：

' 将最新计数同步到表格第一列
objtable.DataBodyRange.Columns(1).Value = currentCount

完整修改后代码 #

Sub GenerateSupplyChain()

Dim MySheet As String, ws As Worksheet
MySheet = Sheets("Instructions").Range("T1").Value
Set ws = Sheets(MySheet)

' 运行次数横向计数逻辑
Dim countCell As Range
Dim currentCount As Integer

' 查找第一行第一个空单元格
Set countCell = ws.Range("1:1").Find(What:="", LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If countCell Is Nothing Then
    MsgBox "第一行已无空单元格，无法记录运行计数", vbExclamation
    Exit Sub
End If

' 计算当前运行次数
currentCount = ws.Range("1:1").Cells(1, ws.Columns.Count).End(xlToLeft).Column
' 处理第一行完全为空的情况
If currentCount = 1 And ws.Range("A1").Value = "" Then
    currentCount = 0
End If
currentCount = currentCount + 1
' 写入计数
countCell.Value = currentCount
    
    Const COL_KEY = "O" ' 用于确定最后一行
    Const FIRST_ROW = 5
    Const HEADER_RNG = "D2:AS2" ' 表头来源
    Const BASE_SHT = "Base Data"
    Dim i As Variant
    i = InputBox("本次供应链包含多少个DFSP？", "输入数量")
    If Not IsNumeric(i) Then
        MsgBox "请输入数字。", vbCritical
        Exit Sub
    End If
    If i < 1 Then Exit Sub
    
    Dim oSht As Worksheet, LastRow As Long
    Set oSht = Sheets(MySheet)
    LastRow = oSht.Cells(oSht.Rows.Count, COL_KEY).End(xlUp).Row
    With oSht.Cells(LastRow, COL_KEY)
        If Len(.Value) > 0 Or (Not .ListObject Is Nothing) Then
            LastRow = LastRow + 2
        End If
        If LastRow < FIRST_ROW Then LastRow = FIRST_ROW
    End With
    Dim tabRng As Range, headerRng As Range, objtable As ListObject
    Set headerRng = Sheets("BASE Data").Range(HEADER_RNG)
    Set tabRng = oSht.Cells(LastRow, COL_KEY).Resize(i + 1, headerRng.Columns.Count)
    Set objtable = Worksheets(MySheet).ListObjects.Add(xlSrcRange, tabRng, , xlYes)
    objtable.HeaderRowRange.Value = headerRng.Value
    objtable.ShowTotals = True
    objtable.TableStyle = "TableStyleLight1"

    ' 将最新计数同步到表格第一列
    objtable.DataBodyRange.Columns(1).Value = currentCount
    
    objtable.DataBodyRange.Cells(1, 6).Formula = _
    "=VLOOKUP([@[" & objtable.HeaderRowRange.Cells(1, 1).Value & "]],'BASE Data'!A:N,3,FALSE)"
    objtable.DataBodyRange.Cells(1, 7).Formula = _
    "=VLOOKUP([@[" & objtable.HeaderRowRange.Cells(1, 1).Value & "]],'BASE Data'!A:N,3,FALSE)"
    objtable.DataBodyRange.Cells(1, 8).Formula = _
    "=VLOOKUP([@[" & objtable.HeaderRowRange.Cells(1, 1).Value & "]],'BASE Data'!A:N,3,FALSE)"
    
End Sub

内容的提问来源于stack exchange，提问作者Ryan Data Guy