展开全部

附件中有完整示例，运行 hb 后会弹出62616964757a686964616fe4b893e5b19e31333337373564选择合并文件夹的对话框，选择后会将被选目录下所有工作薄的工作表合并到一个新建工作薄，为区分方便，原工作薄中的所有工作表合并后的sheet名称以同一颜色显示，并以“原工作薄-原工作表”的格式命名sheet，以下为完整代码Private Sub hb()

Dim hb As Object, kOne As Boolean, tabcolor As Long

Set hb = Workbooks.Add

Application.DisplayAlerts = False

For i = hb.Sheets.Count To 2 Step -1

hb.Sheets(i).Delete

Next

Dim FileName As String, FilePath As String

Dim iFolder As Object, rwk As Object, Sh As Object

Set iFolder = CreateObject(“shell.application”).BrowseForFolder(0, “请选择要合并的文件夹”, 0, “”)

If iFolder Is Nothing Then Exit Sub

FilePath = iFolder.Items.Item.Path

FilePath = IIf(Right(FilePath, 1) = “\”, FilePath, FilePath & “\”)

FileName = Dir(FilePath & “*.xls*”)

Do Until Len(FileName) = 0

If UCase(FilePath & FileName) <> UCase(ThisWorkbook.Path & “\” & ThisWorkbook.Name) Then

Set rwk = Workbooks.Open(FileName:=FilePath & FileName)

tabcolor = Int(Rnd * 56) + 1

With rwk

For Each Sh In .Worksheets

Sh.Copy After:=hb.Sheets(hb.Sheets.Count)

hb.Sheets(hb.Sheets.Count).Name = FileName & “-” & Sh.Name

hb.Sheets(hb.Sheets.Count).Tab.ColorIndex = tabcolor

If Not kOne Then hb.Sheets(1).Delete: kOne = True

Next

.Close True

End With

End If

Set rwk = Nothing

FileName = Dir

Loop

Application.DisplayAlerts = True

End Sub