VBA - 用于跨多个范围的其他尚未创建的新工作表添加值的主工作表
VBA - Main worksheet to add values across other new not yet created worksheets across multilpe ranges
我是 VBA 的新手，喜欢挑战自己，但在这个项目上却不知所措。
我有一个工作簿，其中有很多用于各种计算和求和的选项卡。 "PDP Base" 主选项卡包含所有 "PDP BaseX" 选项卡，并将所有 "PDP BaseX" 选项卡中同一单元格的所有值添加到主选项卡中。当只有 5 个左右 "PDP BaseX" 选项卡时，这很容易手动处理，但如果可能有很多选项卡要加在一起（10+），梳理每个选项卡会很痛苦。如果有多种情况要向 (PNP;PBP;PUD;PBL - 每个都有 Base 和 Sens 修饰符) 添加公式，情况会变得更糟。
每个新的 "PDP BaseX" 选项卡都是由其他代码（尚未完成）从模板 运行 复制粘贴的，具有新的 "X+1" 值，所以我不想只需复制粘贴一个公式，将新选项卡添加到主选项卡中。
最终结果将包含每个类别的所有主要选项卡的代码，但如果我可以获得一个主要选项卡来执行我想要的操作，我可以从那里开始。
下面是一些我觉得很接近的代码，但它在其中某处循环到无穷大并且不会移动通过初始单元格 B29（当结果应该是 10 时溢出到 PDP Base B29；PDP Base1 B29 = 2; PDP Base2 B29 = 6; PDP Base3 B29 = 4)
Private Sub Worksheet_Calculate()
Dim ws As Worksheet, mainws As Worksheet
Dim rng As Range, mainrng As Range
Dim x As Single, y As Single
Dim tVar As Double
Set mainws = ActiveWorkbook.Worksheets("PDP Base")
With mainws
For y = 2 To 4
For x = 29 To 43
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "PDP Base*" And ws.CodeName <> "PDPBase" Then
'the main tab has a codename assigned to it to not add itself
With ws
With .Range(Cells(x, y))
tVar = tVar + .Range(Cells(x, y)).Value
End With
End With
End If
Next ws
Set mainrng = Cells(x, y)
mainrng.Value = tVar
tVar = 0
Next x
Next y
End With
End Sub
有人可以对此发表一些见解吗？谢谢！
未经测试但应该做你想做的事：
Private Sub Worksheet_Calculate()
Const MAIN_WS_NAME As String = "PDP Base" 'use a constant for fixed values
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim x As Long, y As Long 'Long not Single
Dim tVar As Double
Set wb = ActiveWorkbook
Set mainws = wb.Worksheets(MAIN_WS_NAME)
For y = 2 To 4
For x = 29 To 43
tVar = 0
For Each ws In wb.Worksheets
If ws.Name Like MAIN_WS_NAME & "*" And ws.Name <> MAIN_WS_NAME Then
tVar = tVar + ws.Cells(x, y).Value
End If
Next ws
mainws.Cells(x, y).Value = tVar
Next x
Next y
End Sub
自从我 post 编辑了最初的问题以来已经有一段时间了，但从那时起我已经取得了更多进展，只是想 post 我的进步供其他人使用，以防他们需要类似的东西.
还有很多清洁工作可以做，还没有完成，但是基本的想法确实非常很好。该代码采用几个 codenamed（不是选项卡名称；允许用户将选项卡名称更改为不同的名称）主要 sheets 并循环遍历每个，添加动态添加单元格的公式类似命名的 subsheets 进入主 sheet 跨越多个单元格块。
还要感谢 Tim Williams 再次提供的原始答案，因为它极大地帮助我朝着正确的方向前进，并且是下面代码的基础。
使用风险自负。 我听说 CodeNames 并使用 VBProject 类型的代码，如果它们损坏，会给您带来糟糕的一天。
下面的主要代码
Public Sub Sheet_Initilization()
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim codename As String
Dim mainwsname As String
Set wb = ActiveWorkbook
'block code to run code smoother
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'PLACEHOLDER FOR LATER USE CaseNames = Array("PDPBase", "PDPSens", "PBPBase", "PBPSens", "PNPBase", "PNPSens", "PUDBase", "PUDSens")
CaseNames = Array("PDPBase", "PBPBase", "PNPBase", "PUDBase") 'main 4 cases, more to come
For Each c In CaseNames 'cycle through each "Main" case sheet
codename = c
Set mainws = wb.Sheets(CN(wb, codename)) 'calls function to retrieve code name of the main case sheet
'allows users to change main case tab names without messing up the codes
'must change security settings to use, looking into alternatives
mainwsname = mainws.Name 'probably could do without with some optimization
For Each b In Range("InputAdditionCells").Cells 'uses named range of multiple blocks of cells, B29:D34 M29:O43 I53:J68 for example
'cycles through each cell in every block
mainws.Range(b.Address).Formula = "=" 'initial formula
For Each ws In wb.Worksheets 'cycles through each sheet
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then 'finds similarily named sub sheets (PDP Base 1, PDP Base 2...etc)
', but won't use the main sheet (PDP Base)
If b.Address Like "$Y*" Then 'special column to use different offset formula
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Offset(0, 4).Address
Else
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Address
End If
End If
Next ws
Next b
For Each d In Range("InputWeightedCells").Cells 'same idea as before, different main formula (weighted average)
mainws.Range(d.Address).Formula = "="
For Each ws In wb.Worksheets
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then
If d.Address Like "*" Then 'special row to use different offset formula
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-21, 23).Address & ")"
Else
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-24, 23).Address & ")"
End If
End If
Next ws
Next d
MsgBox (mainwsname) 'DELETE; makes sure code is running properly/codebreak without using the break feature
Next c
'reactivate original block code
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub 'cool beans
调用的函数（需要将信任中心设置中的宏设置从 excel 选项更改为 运行）。再次使用风险自负。
Function CN(wb As Workbook, codename As String) As String
CN = wb.VBProject.VBComponents(codename).Properties("Name").Value
End Function
我是 VBA 的新手，喜欢挑战自己，但在这个项目上却不知所措。
我有一个工作簿，其中有很多用于各种计算和求和的选项卡。 "PDP Base" 主选项卡包含所有 "PDP BaseX" 选项卡，并将所有 "PDP BaseX" 选项卡中同一单元格的所有值添加到主选项卡中。当只有 5 个左右 "PDP BaseX" 选项卡时，这很容易手动处理，但如果可能有很多选项卡要加在一起（10+），梳理每个选项卡会很痛苦。如果有多种情况要向 (PNP;PBP;PUD;PBL - 每个都有 Base 和 Sens 修饰符) 添加公式，情况会变得更糟。
每个新的 "PDP BaseX" 选项卡都是由其他代码（尚未完成）从模板 运行 复制粘贴的，具有新的 "X+1" 值，所以我不想只需复制粘贴一个公式，将新选项卡添加到主选项卡中。
最终结果将包含每个类别的所有主要选项卡的代码，但如果我可以获得一个主要选项卡来执行我想要的操作，我可以从那里开始。
下面是一些我觉得很接近的代码，但它在其中某处循环到无穷大并且不会移动通过初始单元格 B29（当结果应该是 10 时溢出到 PDP Base B29；PDP Base1 B29 = 2; PDP Base2 B29 = 6; PDP Base3 B29 = 4)
Private Sub Worksheet_Calculate()
Dim ws As Worksheet, mainws As Worksheet
Dim rng As Range, mainrng As Range
Dim x As Single, y As Single
Dim tVar As Double
Set mainws = ActiveWorkbook.Worksheets("PDP Base")
With mainws
For y = 2 To 4
For x = 29 To 43
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "PDP Base*" And ws.CodeName <> "PDPBase" Then
'the main tab has a codename assigned to it to not add itself
With ws
With .Range(Cells(x, y))
tVar = tVar + .Range(Cells(x, y)).Value
End With
End With
End If
Next ws
Set mainrng = Cells(x, y)
mainrng.Value = tVar
tVar = 0
Next x
Next y
End With
End Sub
有人可以对此发表一些见解吗？谢谢！
未经测试但应该做你想做的事：
Private Sub Worksheet_Calculate()
Const MAIN_WS_NAME As String = "PDP Base" 'use a constant for fixed values
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim x As Long, y As Long 'Long not Single
Dim tVar As Double
Set wb = ActiveWorkbook
Set mainws = wb.Worksheets(MAIN_WS_NAME)
For y = 2 To 4
For x = 29 To 43
tVar = 0
For Each ws In wb.Worksheets
If ws.Name Like MAIN_WS_NAME & "*" And ws.Name <> MAIN_WS_NAME Then
tVar = tVar + ws.Cells(x, y).Value
End If
Next ws
mainws.Cells(x, y).Value = tVar
Next x
Next y
End Sub
自从我 post 编辑了最初的问题以来已经有一段时间了，但从那时起我已经取得了更多进展，只是想 post 我的进步供其他人使用，以防他们需要类似的东西.
还有很多清洁工作可以做，还没有完成，但是基本的想法确实非常很好。该代码采用几个 codenamed（不是选项卡名称；允许用户将选项卡名称更改为不同的名称）主要 sheets 并循环遍历每个，添加动态添加单元格的公式类似命名的 subsheets 进入主 sheet 跨越多个单元格块。
还要感谢 Tim Williams 再次提供的原始答案，因为它极大地帮助我朝着正确的方向前进，并且是下面代码的基础。
使用风险自负。 我听说 CodeNames 并使用 VBProject 类型的代码，如果它们损坏，会给您带来糟糕的一天。
下面的主要代码
Public Sub Sheet_Initilization()
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim codename As String
Dim mainwsname As String
Set wb = ActiveWorkbook
'block code to run code smoother
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'PLACEHOLDER FOR LATER USE CaseNames = Array("PDPBase", "PDPSens", "PBPBase", "PBPSens", "PNPBase", "PNPSens", "PUDBase", "PUDSens")
CaseNames = Array("PDPBase", "PBPBase", "PNPBase", "PUDBase") 'main 4 cases, more to come
For Each c In CaseNames 'cycle through each "Main" case sheet
codename = c
Set mainws = wb.Sheets(CN(wb, codename)) 'calls function to retrieve code name of the main case sheet
'allows users to change main case tab names without messing up the codes
'must change security settings to use, looking into alternatives
mainwsname = mainws.Name 'probably could do without with some optimization
For Each b In Range("InputAdditionCells").Cells 'uses named range of multiple blocks of cells, B29:D34 M29:O43 I53:J68 for example
'cycles through each cell in every block
mainws.Range(b.Address).Formula = "=" 'initial formula
For Each ws In wb.Worksheets 'cycles through each sheet
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then 'finds similarily named sub sheets (PDP Base 1, PDP Base 2...etc)
', but won't use the main sheet (PDP Base)
If b.Address Like "$Y*" Then 'special column to use different offset formula
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Offset(0, 4).Address
Else
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Address
End If
End If
Next ws
Next b
For Each d In Range("InputWeightedCells").Cells 'same idea as before, different main formula (weighted average)
mainws.Range(d.Address).Formula = "="
For Each ws In wb.Worksheets
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then
If d.Address Like "*" Then 'special row to use different offset formula
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-21, 23).Address & ")"
Else
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-24, 23).Address & ")"
End If
End If
Next ws
Next d
MsgBox (mainwsname) 'DELETE; makes sure code is running properly/codebreak without using the break feature
Next c
'reactivate original block code
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub 'cool beans
调用的函数（需要将信任中心设置中的宏设置从 excel 选项更改为 运行）。再次使用风险自负。
Function CN(wb As Workbook, codename As String) As String
CN = wb.VBProject.VBComponents(codename).Properties("Name").Value
End Function