Makro zum Kopieren Header-Formatierung

Question

Ich habe eine Excel-Datei, die 8 Regions Trainingsinformationen und ich habe eine Makro-Setup, das alle 8 Blätter in ein Master-Blatt, das ich verwenden kann, um Pivot zu kompilieren.

Alles funktioniert gut, außer ich kann es nicht richtig formatieren das Master-Blatt richtig.

Der Code für das Kopieren des Header:

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

Ich brauche Verpackung von Text auf allen Spalten und auf ihnen einen Filter haben.

Entire Code:

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 

Alle Ideen, was ich zu diesem Code hinzufügen müssen?

Answer 1

Wenn alle Header gleich sind, kopieren Sie sie einfach auf Ihre erste Reise durch die Schleife:

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