Question

现在我的工作簿有一张主表和30张单独的表。所有人的格式都完全相同，只是为公司内部的不同部门提取信息。有没有办法，结合我用来拉取每个部门的信息的宏，摆脱一个模板工作表的所有单独的工作表？我想更改它，以便当我为特定部门运行宏时，excel会根据模板打开一个新的工作表，然后将当前宏提取的信息放入新工作表中。我现在用来从主工作表中提取的内容如下：

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

此代码应该满足您的需求：

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

注意：您可以根据需要设置模板表，而不是复制模板表以获取新的演示文稿表，上面的代码将清除其中的数据，然后再将新数据复制到其中。而不是仅尝试复制特定列，代码将隐藏您在演示文稿表中不需要的列。

Answer 2

EDIT2：删除所有其他部门表的选项

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

试图改变我的工作簿的工作方式

2 个答案: