私のワークブックの仕組みを再加工しようとしています

Question

現在、私のワークブックにはマスターシートと30枚の個別シートがあります。すべての人物はまったく同じようにフォーマットされ、会社内のさまざまな部門の情報を取得するだけです。 1つのテンプレートワークシートのすべての個々のシートを取り除くために、私が各部門の情報を引き出すために使用するマクロを組み込む方法はありますか？特定の部門のマクロを実行すると、テンプレートに基づいて新しいワークシートが開き、現在のマクロが新しいワークシートにプルする情報が格納されるように、変更したいと考えています。私は、マスターワークシートから引き出すために今使用することは、次のとおりです。

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：他のすべてのdeptシートを削除するオプション

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 

注：代わりに新しいプレゼンテーションシートを得るためにあなたのテンプレートシートを対処し、必要に応じてテンプレートシートを設定するだけです。上のコードでは、新しいデータをコピーする前にその上のデータを消去します。また、特定の列をコピーするだけでなく、プレゼンテーションシートに表示したくない列を非表示にします。