VBA 合并文件夹下工作簿中所有表格

功能 ： 将指定文件夹下所有工作簿中表格 ，合并到一个工作簿中并保存到桌面

附上源码：

Sub 合并()

Dim fileName As String

Dim folderPath As String

Dim folderOutpath As String

Dim isGoOn As Boolean

Dim targetWorkbook As Workbook
 
Dim randomColor As Long

Dim line As Integer

Dim workBookLine As Integer


line = 1

isGoOn = True

Application.ScreenUpdating = False

Application.DisplayAlerts = False

folderPath = SelectFolder

'folderPath = "C:\Users\Administrator\Desktop\新建文件夹\"

If (folderPath = "") Then
 Exit Sub
  End If

folderPath = InputBox("文件夹路径", "合并", folderPath)

  If (folderPath = "") Then
  Exit Sub
  End If

 ' 打开一个新的工作簿作为目标工作簿
    Set targetWorkbook = Workbooks.Add
 
 fileName = Dir(folderPath)
 
   Do While fileName <> "" And isGoOn
        
        
  Set Workbook = Workbooks.Open(folderPath & fileName)
        
        randomColor = GetRandomColor()
        
        targetWorkbook.Sheets(1).Cells(line, 1) = Workbook.Name
        
        workBookLine = line
        
        For Each mySheet In Workbook.Sheets
    
                If (Application.WorksheetFunction.CountA(mySheet.Cells)) Then
    
                   mySheet.Name = workBookLine & "-" & mySheet.Name
                 
                   mySheet.Tab.Color = randomColor
                
                   mySheet.Copy after:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
 
                   line = line + 1

                   targetWorkbook.Sheets(1).Cells(line, 2) = mySheet.Name
               
                  End If
                  

            Next
      
               line = line + 1

         isGoOn = ShowConfirmationDialog(Workbook.Name)

        Workbook.Close

        fileName = Dir
        
    Loop
    
    Application.ScreenUpdating = True

    Application.DisplayAlerts = True
    
    Worksheets(1).Activate
    
    
    
    Dim filePath As String
    
    Dim desktopPath As String
    
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    filePath = desktopPath & "\合并后的工作簿.xlsx" ' 可以根据需要修改文件名和扩展名
    
    targetWorkbook.SaveAs filePath

    targetWorkbook.Close SaveChanges:=False

    MsgBox "文件已保存到桌面。"

   

End Sub

Function GetRandomColor() As Long
    Randomize
    GetRandomColor = RGB(Int((256 * Rnd) + 1), Int((256 * Rnd) + 1), Int((256 * Rnd) + 1))
End Function


Function SelectFolder()

Dim folderPath As String

With Application.FileDialog(msoFileDialogFolderPicker)
   .InitialFileName = ThisWorkbook.Path
   .Title = "选择文件夹"
   If .Show = True Then
       folderPath = .SelectedItems(1) & "\"
    End If
    End With
 SelectFolder = folderPath

End Function


Function ShowConfirmationDialog(ByVal workBookName As String) As Boolean


    Dim goOn As Boolean

    Dim result As Integer
 
    result = MsgBox("已将 " & workBookName & " 中表格合并 是否继续合并？", vbOKCancel)
    
  If result = vbOK Then
        goOn = True
    ElseIf result = vbCancel Then
            goOn = False
    End If
    
    ShowConfirmationDialog = goOn
End Function