要复制标题格式的macros

我有一个Excel文件，有8个地区的培训信息，我有一个macros的设置，将所有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