Пытаюсь переделать, как работает моя книга

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

РЕДАКТИРОВАТЬ 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