需要帮助合并Excel VBA的两个macros

这两个macros都是我在网上find的，适合我使用的macros。 我正在使用这个代码，它可以很好地将特定的数据分成新的工作表：

Sub Copy_To_Worksheets() 'Note: This macro use the function LastRow Dim My_Range As Range Dim FieldNum As Long Dim CalcMode As Long Dim ViewMode As Long Dim ws2 As Worksheet Dim Lrow As Long Dim cell As Range Dim CCount As Long Dim WSNew As Worksheet Dim ErrNum As Long 'Set filter range on ActiveSheet: A1 is the top left cell of your filter range 'and the header of the first column, D is the last column in the filter range. 'You can also add the sheet name to the code like this : 'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1"))) 'No need that the sheet is active then when you run the macro when you use this. Set My_Range = Range("A1:Z" & Range("A" & Rows.Count).End(xlUp).Row) My_Range.Parent.Select If ActiveWorkbook.ProtectStructure = True Or _ My_Range.Parent.ProtectContents = True Then MsgBox "Sorry, not working when the workbook or worksheet is protected", _ vbOKOnly, "Copy to new worksheet" Exit Sub End If 'This example filters on the first column in the range(change the field if needed) 'In this case the range starts in A so Field:=1 is column A, 2 = column B, ...... FieldNum = 5 'I changed this to 3 for column C 'Turn off AutoFilter My_Range.Parent.AutoFilterMode = False 'Change ScreenUpdating, Calculation, EnableEvents, .... With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView ActiveSheet.DisplayPageBreaks = False 'Add a worksheet to copy the a unique list and add the CriteriaRange Set ws2 = Worksheets.Add With ws2 'first we copy the Unique data from the filter field to ws2 My_Range.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True 'loop through the unique list in ws2 and filter/copy to a new sheet Lrow = .Cells(Rows.Count, "A").End(xlUp).Row For Each cell In .Range("A2:A" & Lrow) 'Filter the range My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _ Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?") 'Check if there are no more then 8192 areas(limit of areas) CCount = 0 On Error Resume Next CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _ .Areas(1).Cells.Count On Error GoTo 0 If CCount = 0 Then MsgBox "There are more than 8192 areas for the value : " & cell.Value _ & vbNewLine & "It is not possible to copy the visible data." _ & vbNewLine & "Tip: Sort your data before you use this macro.", _ vbOKOnly, "Split in worksheets" Else 'Add a new worksheet Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count)) On Error Resume Next WSNew.Name = cell.Value If Err.Number > 0 Then ErrNum = ErrNum + 1 WSNew.Name = "Error_" & Format(ErrNum, "0000") Err.Clear End If On Error GoTo 0 'Copy the visible data to the new worksheet My_Range.SpecialCells(xlCellTypeVisible).Copy With WSNew.Range("A1") ' Paste:=8 will copy the columnwidth in Excel 2000 and higher ' Remove this line if you use Excel 97 .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False .Select End With End If 'Show all data in the range My_Range.AutoFilter Field:=FieldNum Next cell 'Delete the ws2 sheet On Error Resume Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True On Error GoTo 0 End With 'Turn off AutoFilter My_Range.Parent.AutoFilterMode = False If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _ & vbNewLine & "There are characters in the name that are not allowed" _ & vbNewLine & "in a sheet name or the worksheet already exist." End If 'Restore ScreenUpdating, Calculation, EnableEvents, .... My_Range.Parent.Select ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub 

我需要帮助的是将一组特定的公式添加到从上面的macros创build的每个工作表的底部。 下面的macros将公式添加到工作簿中的所有工作表。 我需要它将公式添加到上面的macros中创build的工作表。 生成的图纸数量在每次生成时都会更改，具体取决于源数据。 我认为最好把底部的macros合并到顶部，但我不知道该怎么做。

 Sub Insert_Formulas() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Activate 'Start NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1 With Cells(NxtRw, "B") .Value = "Total Open Cases" End With With Cells(NxtRw, "C") .EntireRow.Insert .Value = "Total Closed Cases" End With 'Next Row below NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1 With Cells(NxtRw, "B") .Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Open*"")" End With With Cells(NxtRw, "C") .Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Closed*"")" End With Next End Sub 

任何帮助将不胜感激。

谢谢你

Answer 1

如果参数化函数，以便将需要公式的工作表作为参数

 Sub Insert_Formulas_Into_WorkSheet(ws As Worksheet) ws.Activate 'Start NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1 With Cells(NxtRw, "B") .Value = "Total Open Cases" End With With Cells(NxtRw, "C") .EntireRow.Insert .Value = "Total Closed Cases" End With 'Next Row below NxtRw = Cells(Rows.Count, "B").End(xlUp).Row + 1 With Cells(NxtRw, "B") .Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Open*"")" End With With Cells(NxtRw, "C") .Formula = "=CountIf(B2:B" & NxtRw - 1 & ", ""Closed*"")" End With End Sub 

然后，可以通过调用创build每个新的工作表之后添加公式

  Insert_Formulas_Into_WorkSheet WSNew 

Answer 2

我不会合并这两个macros，只需在需要时调用Insert_Formulasmacros中的Copy_To_Worksheetsmacros即可。

要调用macros，你需要的是这一行：

 Insert_Formulas 

编辑以回应评论：

鉴于你不知道有多less张正在添加我有一个build议，你可以尝试。

高级别，将文本添加到每个工作表中的单元格，以指示它是否是新的。 当新的表单被创build时，单元格会说“新”。 不新时，应该说“现有”。 然后在

如果你想尝试一下，让我知道什么是行不通的，我可以检查并帮助更新代码。

1. 在Copy_To_Worksheetsmacros中，您需要添加一行以将所有现有工作表设置为“现有”
2. 然后在Copy_To_Worksheetsmacros中添加一行，以便新工作表设置为“新”
3. 在Insert_Formulasmacros中，仍循环遍历所有工作表，但检查工作表是否为“新build”，如果是，则运行代码以添加公式。

更清洁（但稍微困难）的select是在每张纸上定义一个名称（每个纸张使用相同的名称，并将范围限制在每​​张纸上），并在每张纸上使用该名称而不是单元格。