내 통합 문서의 작동 방식을 재검토하려합니다.

Question

지금 통합 문서에는 하나의 마스터 시트와 30 가지 개별 시트가 있습니다. 모든 개인은 똑같은 포맷으로되어 있으며 회사 내의 여러 부서에 대한 정보 만 가져옵니다. 하나의 템플릿 워크 시트에 대한 모든 개별 시트를 없애기 위해 각 부서의 정보를 가져 오는 데 사용하는 매크로를 통합하는 방법이 있습니까? 특정 부서의 매크로를 실행할 때 템플릿을 기반으로 새 워크 시트를 열고 내 현재 매크로가 새 워크 시트에 가져 오는 정보를 넣도록 변경하고 싶습니다. 내가 마스터 워크 시트에서 끌어 지금 사용하는 것은 다음과

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

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 

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 

주 : 대신 새 프레젠테이션 시트를 얻을 수 있도록 템플릿 시트를 대처, 템플릿 시트를 원하는대로 설정하면 위의 코드에서 새 데이터를 복사하기 전에 데이터를 지울 수 있습니다. 특정 열만 복사하는 대신 코드는 프레젠테이션 시트에서 원하지 않는 열을 숨 깁니다.