Question

我有一个excel文件，其中包含8个区域的培训信息，我有一个宏设置，可以将所有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

用于复制标题格式的宏

1 个答案: