マクロをヘッダーの書式設定にコピーする

Question

私は8つの地域のトレーニング情報を持つExcelファイルを持っており、8つのシートすべてをピボットに使用できるマスターシートにコンパイルするマクロセットアップがあります。

マスターシートを適切に正しくフォーマットすることができない場合を除き、すべて正常に動作します。

ヘッダのコピーのためのコード：

If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then 
     sh.Range("A1:Z1").Copy DestSh.Range("A1") 
    End If 

私はすべてのカラム上のテキストの折り返しを必要とし、それらにフィルタを持っています。

コード全体：私はこのコードを追加する必要があるものに

Select Code copy to clipboard 
Sub CopyDataWithHeaders() 
    Dim sh As Worksheet 
    Dim DestSh As Worksheet 
    Dim Last As Long 
    Dim shLast As Long 
    Dim CopyRng As Range 
    Dim StartRow As Long 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Delete the sheet "Master Sheet" if it exist 
    Application.DisplayAlerts = False 
    On Error Resume Next 
    ActiveWorkbook.Worksheets("Master Sheet").Delete 
    On Error GoTo 0 
    Application.DisplayAlerts = True 

    'Add a worksheet with the name "Master Sheet" 
    Set DestSh = ActiveWorkbook.Worksheets.Add 
    DestSh.Name = "Master Sheet" 

    'Fill in the start row 
    StartRow = 2 

    'loop through all worksheets and copy the data to the DestSh 
    For Each sh In ActiveWorkbook.Worksheets 
     If sh.Name <> DestSh.Name Then 

    'Copy header row, change the range if you use more columns 
    If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then 
     sh.Range("A1:Z1").Copy DestSh.Range("A1") 
    End If 

      'Find the last row with data on the DestSh and sh 
      Last = LastRow(DestSh) 
      shLast = LastRow(sh) 

      'If sh is not empty and if the last row >= StartRow copy the CopyRng 
      If shLast > 0 And shLast >= StartRow Then 

       'Set the range that you want to copy 
       Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) 

       'Test if there enough rows in the DestSh to copy all the data 
       If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
        MsgBox "There are not enough rows in the Destsh" 
        GoTo ExitTheSub 
       End If 

       'This example copies values/formats, if you only want to copy the 
       'values or want to copy everything look below example 1 on this page 
       CopyRng.Copy 
       With DestSh.Cells(Last + 1, "A") 
        .PasteSpecial xlPasteValues 
        .PasteSpecial xlPasteFormats 
        Application.CutCopyMode = False 
       End With 

      End If 

     End If 
    Next 

ExitTheSub: 

    Application.Goto DestSh.Cells(1) 

    'AutoFit the column width in the DestSh sheet 
    DestSh.Columns.AutoFit 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
End Sub 

Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 

任意のアイデア？

Answer 1

すべてのヘッダが同じであれば、単にループを通して、あなたの最初の旅行にそれらをコピー：

StartRow = 1 

For Each sh In ActiveWorkbook.Worksheets 
    If sh.Name <> DestSh.Name Then 
     Last = LastRow(DestSh) 
     shLast = LastRow(sh) 
     If shLast > 0 And shLast >= StartRow Then 
      Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) 
      If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
       MsgBox "There are not enough rows in the Destsh" 
       GoTo ExitTheSub 
      End If 

      CopyRng.Copy 
      With DestSh.Cells(Last + 1, "A") 
       .PasteSpecial xlPasteValues 
       .PasteSpecial xlPasteFormats 
       Application.CutCopyMode = False 
      End With 
      If StartRow = 1 Then StartRow = 2 
     End If 
    End If 
Next