VBA多个工作簿里面的多个表的合并单元格拆分并填充

您好，对于您的问题，我可以提供以下代码来合并多个工作簿里的多个表，并将合并后的单元格拆分并填充数据：

Sub MergeWorksheets()
    Dim mainWorkbook As Workbook
    Dim mainWorksheet As Worksheet
    Dim folderPath As String
    Dim selectedFiles() As String
    Dim i As Integer
    Dim j As Integer
    Dim lastRow As Long
    Dim lastCol As Long
    Dim sourceRange As Range
    Dim destRange As Range
    
    '选择要合并的工作簿
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要合并的工作簿所在的文件夹"
        If .Show <> -1 Then
            MsgBox "您没有选择任何文件夹，请重新运行该宏。", vbExclamation, "提示"
            Exit Sub
        End If
        folderPath = .SelectedItems(1)
    End With
    
    '获取要合并的工作簿中所有表的名称
    selectedFiles = GetFilesInFolder(folderPath)
    
    '创建一个新的工作簿，并将第一个表复制到其中
    Set mainWorkbook = Workbooks.Add
    Workbooks(selectedFiles(0)).Sheets(1).Copy Before:=mainWorkbook.Sheets(1)
    Set mainWorksheet = mainWorkbook.Sheets(1)
    mainWorksheet.Name = "合并后的表"
    lastRow = mainWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
    lastCol = mainWorksheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Set destRange = mainWorksheet.Range(mainWorksheet.Cells(1, 1), mainWorksheet.Cells(lastRow, lastCol))
    
    '循环遍历所有要合并的工作簿和表，并将它们合并到新的工作簿中
    For i = 1 To UBound(selectedFiles)
        For j = 1 To Workbooks(selectedFiles(i)).Sheets.Count
            Set sourceRange = Workbooks(selectedFiles(i)).Sheets(j).UsedRange
            lastRow = destRange.Cells(Rows.Count, 1).End(xlUp).Row
            Set destRange = destRange.Offset(1).Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
            destRange.Value = sourceRange.Value
        Next j
    Next i
    
    '拆分合并的单元格并填充数据
    Dim cell As Range
    For Each cell In destRange
        If cell.MergeCells Then
            cell.UnMerge
            cell.Value = cell.MergeArea.Cells(1, 1).Value
            cell.Resize(cell.MergeArea.Rows.Count, cell.MergeArea.Columns.Count).Merge
        End If
    Next cell
    
    MsgBox "合并完成！", vbInformation, "提示"
End Sub

Function GetFilesInFolder(folderPath As String) As String()
    Dim files() As String
    Dim fileName As String
    Dim i As Integer
    
    fileName = Dir(folderPath & "\*.xlsx")
    While fileName <> ""
        ReDim Preserve files(i)
        files(i) = fileName
        i = i + 1
        fileName = Dir
    Wend
    
    GetFilesInFolder = files
End Function

请注意，此代码仅适用于扩展名为xlsx的工作簿，如果您要合并其他类型的工作簿，请相应地更改代码。

另外，请在运行此代码之前备份您的数据，以避免不必要的数据丢失。