Question

我对VBA很陌生并且喜欢挑战自己，但是我对这个项目感到茫然。

我有一个工作簿，有很多标签用于各种计算和求和。＆＃34; PDP Base＆＃34;主选项卡采用所有＆＃34; PDP BaseX＆＃34;选项卡并在所有＆＃34; PDP BaseX＆＃34;中添加同一单元格的所有值。标签到主要的一个。当只有5个左右的时候，这很容易手动处理。＆lt; PDP BaseX＆＃34;标签，但如果有可能有很多标签要加在一起（10+），那么梳理每个标签都很痛苦。如果有多种情况需要添加公式（PNP; PBP; PUD; PBL - 每个都有Base和Sens修饰符），情况会更糟。

每个新的＆＃34; PDP BaseX＆＃34;选项卡是从其他代码（尚未完成）运行的模板中复制粘贴的，其中包含新的＆＃34; X + 1＆＃34;价值，所以我不想复制粘贴公式，将新标签添加到主标签中。

最终结果将包含每个类别的所有主要选项卡的代码，但如果我可以让一个主选项卡执行我想要的操作，我可以从那里开始。

下面是一些我觉得很接近的代码，但它在那里的某个地方循环到无穷大并且不会移动通过初始单元格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

有人能够对此有所了解吗？谢谢！

Answer 1

未经测试但应该做你想做的事：

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

Answer 2

自从我发布原始问题以来，它已经有点了，但是从那时起我已经进一步发展了，只是想发布我的进展以便其他人使用，因为他们需要类似的东西。

仍然有很多可以完成的清洁，但尚未完成，但基本的想法确实非常。代码需要几个代号（不是标签名称;允许用户将标签名称更改为不同的名称）主页和循环每个，添加公式，动态地将类似命名的子标签中的单元格添加到主页中多个细胞块。

还要感谢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 "*$68" 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 - 主要工作表，用于跨多个范围在其他尚未创建的新工作表中添加值

2 个答案: