任務1描述

選擇某一文件夾內的若干工作簿，將每一個工作簿的工作表全部合併到同一工作簿。

過程代碼：

Sub mergeeveryonexlssheet()

On Error Resume Next

Dim books As Variant, booksN As Variant '選擇的簿和表

Dim booksNopen As Workbook '打開的簿和表

Dim sheetNi As Worksheet

Application.ScreenUpdating = False

Application.DisplayAlerts = False

books = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx ;*.xlsm),*.xls; *.xlsx; *.xlsm,所有文件(*.*),*.*", _

Advertisements

Title:="Excel選擇", MultiSelect:=True)

For Each booksN In books

If booksN <> False Then

Set booksNopen = Workbooks.Open(booksN)

For Each sheetNi In ActiveWorkbook.Sheets

sheetNi.Copy Before:=ThisWorkbook.Sheets(1)

Next

booksNopen.Close

End If

Next

Application.ScreenUpdating = True

Application.DisplayAlerts = True

Advertisements

End Sub

代碼分析：

1.1 books = Application.GetOpenFilename()得到工作簿集合

1.2 外循環：打開工作簿集合中的每一個工作簿；

1.2 內循環：複製打開的工作簿內的每一個工作表到ThisWorkbook。

任務2描述

將一個工作簿中的全部工作表以工作表的名字另存為一個單獨的工作簿。

過程代碼：

Sub 拆分工作簿()

Dim fd As FileDialog, path As String, sht As Worksheet

'彈出對話框，讓用戶選擇文件夾

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

'如果選擇了文件夾則記錄地路徑

If fd.Show = -1 Then

path = fd.SelectedItems(1) & IIf(Right(fd.SelectedItems(1), 1) = "\", "", "\")

Else: Exit Sub

End If

'遍工作表

For Each sht In Sheets

'將工作表複製到新工作簿中（相當於新建一個文件，再將當前表複製到其中,但新工作簿中僅僅包括一個工作表）

sht.Copy

'將新工作簿保存在剛才選擇的路徑中，且以工作表名做為工作簿名

ActiveWorkbook.SaveAs path & sht.Name, xlWorkbookDefault

'關閉工作簿

ActiveWorkbook.Close

Next sht

End Sub

代碼分析：

2.1 通過Application.FileDialog()得到的文件對話框對象，通過其屬性得到文件需要保存的路徑；

2.2 建立For Each sht In Sheets循環；

2.3 循環內工作表的複製：Worksheet.Copy；

2.4 循環內工作表保存：ActiveWorkbook.SaveAs。