Question

我需要做一些符合我想要的代码。第一位，基于主选项卡创建新工作表并从中填充数据。第二行找到最后一行数据，并在列L到AJ的第一个空单元格中添加总和公式。我一直在尝试将它们组合在一起，以便运行一个宏。因此，当填充新工作表时，它还会运行总和公式。非常感谢任何帮助。

创建新工作表并填充：

Option Explicit

Sub SheetsFromTemplate()
'Create copies of a template sheet using text on a master sheet in a specific column
'Sheetname strings are corrected using the UDF below
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, NM As Range, NmSTR As String, NR As Long

With ThisWorkbook                                               'keep focus in this workbook
    Set wsTEMP = .Sheets("Template")                            'sheet to be copied
    wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)              'check if it's hidden or not
    If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible      'make it visible

    Set wsMASTER = .Sheets("Master")                            'sheet with names
                                                                'range to find names to be checked
    Set shNAMES = wsMASTER.Range("A2:A" & Rows.Count).SpecialCells(xlFormulas)     'or xlFormulas

    Application.ScreenUpdating = False                          'speed up macro
    For Each NM In shNAMES                                      'check one name at a time
        NmSTR = FixStringForSheetName(CStr(NM.Text))            'use UDF to create a legal sheetname
        If Not Evaluate("ISREF('" & NmSTR & "'!A1)") Then       'if sheet does not exist...
            wsTEMP.Copy After:=.Sheets(.Sheets.Count)           '...create it from template
            ActiveSheet.Name = NmSTR                            '...rename it
        End If
        With .Sheets(NmSTR)
            NR = .Range("B" & .Rows.Count).End(xlUp).Offset(1).Row
            wsMASTER.Range("B1:B1").Copy
            .Range("A" & NR).PasteSpecial xlPasteValues, Transpose:=True
            NM.Resize(, 500).Copy .Range("A" & NR)
        End With

    Next NM

    wsMASTER.Activate                                           'return to the master sheet
    If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden       'hide the template if necessary
    Application.ScreenUpdating = True                           'update screen one time at the end
End With

MsgBox "All sheets created"
End Sub


Function FixStringForSheetName(shSTR As String) As String

'replace each forbidden character with something acceptable
    shSTR = Replace(shSTR, ":", "")
    shSTR = Replace(shSTR, "?", "")
    shSTR = Replace(shSTR, "*", "")
    shSTR = Replace(shSTR, "/", "-")
    shSTR = Replace(shSTR, "\", "-")
    shSTR = Replace(shSTR, "[", "(")
    shSTR = Replace(shSTR, "]", ")")

'sheet names can only be 31 characters
    FixStringForSheetName = Trim(Left(shSTR, 31))

End Function

将总和公式添加到最后一行：

Option Explicit

Sub SubUntilLastRow()
Dim CurCal As XlCalculation
Dim wb As Workbook, ws As Worksheet, colsLastRow As Long
Dim cols As Variant, SumCols As Long, colsArray As Variant
Dim biggestRow As Long
Dim shNAMES As Range

With ThisWorkbook
    Application.ScreenUpdating = False
    CurCal = Application.Calculation
    Application.Calculation = xlCalculationManual

    biggestRow = 1

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("CPB - NAM")

    colsArray = Array("L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ")

    For Each cols In colsArray
    colsLastRow = ws.Cells(Rows.Count, cols).End(xlUp).Row
    If colsLastRow > biggestRow Then
    biggestRow = colsLastRow + 1
    End If
    Next cols

    For Each cols In colsArray
    colsLastRow = ws.Cells(Rows.Count, cols).End(xlUp).Row
    ws.Cells(biggestRow, cols).Formula = "=SUM(" & cols & "9:" & cols & colsLastRow & ")"
    Next cols

    ws.Range("B" & biggestRow).Value = "TOTAL"

    Application.ScreenUpdating = True
    Application.Calculation = CurCal
End With

End Sub

Answer 1

首先转换你的Sub

Sub SubUntilLastRow()

进入一个将工作表作为参数的函数

Function SubUntilLastRow(ws As Worksheet)

删除以下代码行：

Set wb = ThisWorkbook
Set ws = wb.Sheets("CPB - NAM")

并在For Each NM In shNAMES循环中将行放在底部 SubUntilLastRow（NM）

调用相应工作表的函数

组合两个VBA位代码

1 个答案: