试图重写我的工作簿的工作方式

现在我的工作簿有一张主表和30个单独的表单。 所有的个人格式都完全一样，只是为公司内不同部门提供信息。 有没有办法，结合我用来拉每个部门的信息，以摆脱一个模板工作表的所有单个工作表的macros？ 我想改变它，以便当我运行特定部门的macros时，Excel将打开一个基于模板的新工作表，然后将我当前的macros所引用的信息放入新的工作表中。 我现在使用的主要工作表是：

Sub DepartmentName() Dim LCopyToRow As Long Dim LCopyToCol As Long Dim arrColsToCopy Dim c As Range, x As Integer On Error GoTo Err_Execute arrColsToCopy = Array(1, 3, 4, 8, 25, 16, 17, 15) 'which columns to copy ? Set c = Sheets("MasterSheet").Range("Y5") 'Start search in Row 5 LCopyToRow = 10 'Start copying data to row 10 in DepartmentSheet While Len(c.Value) > 0 'If value in column Y ends with "2540", copy to DepartmentSheet If c.Value Like "*2540" Then LCopyToCol = 1 Sheets("DepartmentSheet").Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=x1Down For x = LBound(arrColsToCopy) To UBound(arrColsToCopy) Sheets("DepartmentSheet").Cells(LCopyToRow, LCopyToCol).Value = _ c.EntireRow.Cells(arrColsToCopy(x)).Value LCopyToCol = LCopyToCol + 1 Next x LCopyToRow = LCopyToRow + 1 'next row End If Set c = c.Offset(1, 0) Wend 'Position on cell A5 Range("A5").Select MsgBox "All matching data has been copied." Exit Sub Err_Execute: MsgBox "An error occurred." End Sub 

我想插入一些东西，以便它打开一个模板，然后完全按照上面的方式发布信息。

Answer 1

编辑2：选项删除所有其他部门表

 Sub Tester() CreateDeptReport "2540" 'just recreates the dept sheet 'CreateDeptReport "2540", True 'also removes all other depts End Sub Sub CreateDeptReport(DeptName As String, Optional ClearAllSheets As Boolean = False) Const TEMPLATE_SHEET As String = "Report template" 'your dept template Const MASTER_SHEET As String = "MasterSheet" Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet Dim LCopyToRow As Long Dim LCopyToCol As Long Dim arrColsToCopy Dim c As Range, x As Integer Dim sht As Excel.Worksheet On Error GoTo Err_Execute arrColsToCopy = Array(1, 3, 4, 8, 25, 16, 17, 15) 'which columns to copy ? Set shtMaster = ThisWorkbook.Sheets(MASTER_SHEET) Set c = shtMaster.Range("Y5") 'Start search in Row 5 LCopyToRow = 10 'Start copying data to row 10 in DepartmentSheet While Len(c.Value) > 0 'If value in column Y ends with dept name, copy to report sheet If c.Value Like "*" & DeptName Then 'only create the new sheet if any records are found If shtRpt Is Nothing Then For Each sht In ThisWorkbook.Sheets If sht.Name <> MASTER_SHEET And sht.Name <> _ TEMPLATE_SHEET Then If ClearAllSheets Or sht.Name = DeptName Then Application.DisplayAlerts = False sht.Delete Application.DisplayAlerts = True End If End If Next sht ThisWorkbook.Sheets(TEMPLATE_SHEET).Copy after:=shtMaster Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1) shtRpt.Name = DeptName 'rename new sheet to Dept name End If LCopyToCol = 1 shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown For x = LBound(arrColsToCopy) To UBound(arrColsToCopy) shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _ c.EntireRow.Cells(arrColsToCopy(x)).Value LCopyToCol = LCopyToCol + 1 Next x LCopyToRow = LCopyToRow + 1 'next row End If Set c = c.Offset(1, 0) Wend Range("A5").Select 'Position on cell A5 MsgBox "All matching data has been copied." Exit Sub Err_Execute: MsgBox "An error occurred." End Sub 

Answer 2

这段代码应该做你所需要的：

 Sub Test() CreateDepartmentReport ("2540") End Sub Sub CreateDepartmentReport(strDepartment) Sheets("DepartmentSheet").UsedRange.Offset(10).ClearContents With Sheets("MasterSheet").Range("C4", Sheets("MasterSheet").Cells(Rows.Count, "C").End(xlUp)) .AutoFilter Field:=1, Criteria1:="=*" & strDepartment, Operator:=xlAnd .SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("DepartmentSheet").[A10] End With With Sheets("MasterSheet") If .AutoFilterMode Then .AutoFilterMode = False End With Sheets("DepartmentSheet").Range("B:B,E:G,I:X").EntireColumn.Hidden = True MsgBox "All matching data has been copied.", vbInformation, "Alert!" End Sub 

注意：只要按照需要设置您的模板，您可以不使用您的模板来获取新的演示文稿，而是在复制新数据之前，上面的代码将清除其中的数据。 而不是只尝试复制特定的列，代码将隐藏您不希望在您的演示文稿表中的列。