Excel VBA多工作薄復制

代碼功能：

1.逐個打開當前工作薄所在文件夾下除當前工作薄外的所有工作薄；

2.歷遍所有非空工作表，第一次連標題一起復制，第二次及以上逐個復制除標題外所有數據到活動工作表。

以下是代碼運行效果：

以下每句代碼增加注釋：

Sub 多工作薄復制()

    '定義變量

    Dim MyPath As String,MyName As String, Acsht As Worksheet, Sht As Worksheet, m As Long, i As Integer

    Dim aCount As Integer

    '提示輸入標題行數

    aCount =Application.InputBox('輸入標題行數：', , , , , , , 1)

    '如果點擊取消，則退出程序

    If aCount = 0 Then Exit Sub

    '關閉屏幕更新，提高運行速度

    Application.ScreenUpdating= False

    '把當前活動工作表賦值給變量Acsht

    Set Acsht = ActiveSheet

    '計算當前工作薄所在文件夾路徑

    MyPath = ThisWorkbook.Path& IIf(Right(ThisWorkbook.Path, 1) = '\', '','\')

    '返回當前文件夾中第一個Excel文件名稱

    MyName = Dir(MyPath &'*.xls*')

    '清空當前活動工作表內容

    Acsht.Cells.Clear

    '以下開始歷遍當前工作薄所在文件夾所有Excel文件

    Do While MyName <>''

            ' 如果工作薄名稱不是當前工作薄名稱

            If MyName <>ThisWorkbook.Name Then

                    '打開該工作薄

                    WithWorkbooks.Open(MyPath & MyName)

                            '歷遍該工作薄所有工作表

                           For i = 1 To .Sheets.Count

                                   '如果工作表為空表則跳過該工作表

                                   If Application.WorksheetFunction.CountA(.Sheets(i).Cells) = 0 Then GoToAA

                                   '變量m自加1

                                   m = m 1

                                   '如果變量m等于1

                                    If m = 1 Then

                                        '把工作表所有連標題數據復制到活動工作表的單元格A1

                                        .Sheets(i).UsedRange.Copy Acsht.[a1]

                                   Else

                                       '否則把工作表除標題外的數據復制到活動工作表的最后一行非空行下面的第一行空行

                                        .Sheets(i).UsedRange.Offset(aCount).Copy Acsht.Cells(Rows.Count,1).End(xlUp).Offset(1)

                                   End If

AA:

                             Next i

                             '不保存關閉該工作薄

                           .Close False

                    End With

            End If

            '繼續下一個工作薄

            MyName = Dir

    Loop

    '恢復工作薄屏幕更新

    Application.ScreenUpdating= True

End Sub

好了，今天的分享就到這里，覺得文章有用，請給我們點個贊，謝謝！