vba批量合并and拆分多个Excel文件

标签：Dim vba Set End 文件 Excel Cells 合并拆分

　　1、拆分：一个文件按照某一列的类型，拆分成多个文件：

 Private Sub SplitDataByColumn()
'学习代码
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim lastRow As Long
    Dim columnToSplit As Range
    Dim uniqueValues As Collection
    Dim cellValue As Variant
    Dim newWorkbook As Workbook
    Dim newWorksheet As Worksheet
    Dim i As Long
    Dim desktopPath As String
    
    ' 打开源工作簿
    Set sourceWorkbook = ThisWorkbook ' 这里假设源数据在当前活动工作簿中，你可以根据需要进行修改
    Set sourceWorksheet = sourceWorkbook.Sheets("Sheet1") ' 修改为源数据所在的工作表名称
    '设置桌面路径
    desktopPath = Environ("USERPROFILE") & "\Desktop\"
    
    ' 设置拆分列，这里假设要按照第一列（A列）拆分，你可以根据需要修改
    Set columnToSplit = sourceWorksheet.Range("A2:A" & sourceWorksheet.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 创建一个集合用于存储唯一值
    Set uniqueValues = New Collection
    
    ' 遍历拆分列，获取唯一值
    On Error Resume Next
    For Each cellValue In columnToSplit
        uniqueValues.Add cellValue, CStr(cellValue)
    Next cellValue
    On Error GoTo 0
    
    ' 循环创建并保存每个拆分文件
    For i = 1 To uniqueValues.Count
        ' 创建新的工作簿
        Set newWorkbook = Workbooks.Add
        Set newWorksheet = newWorkbook.Sheets(1)
        
        ' 拷贝源数据到新工作簿
        sourceWorksheet.Copy Before:=newWorkbook.Sheets(1)
        Set newWorksheet = newWorkbook.Sheets(1)
        
        ' 删除不匹配的行
        lastRow = newWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
        For j = lastRow To 2 Step -1
            If newWorksheet.Cells(j, 1).value <> uniqueValues(i) Then
                newWorksheet.Rows(j).Delete
            End If
        Next j
        
        ' 保存新工作簿
        newWorkbook.SaveAs desktopPath & "Split_" & uniqueValues(i) & ".xlsx" ' 修改为你想要保存的文件夹路径
        
        ' 关闭新工作簿
        newWorkbook.Close SaveChanges:=False
    Next i
    
    ' 提示拆分完成
    MsgBox "拆分完成！"
End Sub

Sub SplitDataByColumnValue()
    Dim sourceFilePath As Variant
    Dim saveFolderPath As Variant
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim lastRow As Long
    Dim columnToSplit As String
    Dim uniqueValues As Collection
    Dim value As Variant
    
    ' 选择要拆分的文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "选择要拆分的Excel文件"
        .Filters.Add "Excel Files", "*.xlsx; *.xls"
        .AllowMultiSelect = False
        If .Show = -1 Then
            sourceFilePath = .SelectedItems(1)
        Else
            MsgBox "未选择文件。拆分操作已取消。", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 选择保存文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择保存文件夹。拆分操作已取消。", vbExclamation
            Exit Sub
        End If
        saveFolderPath = .SelectedItems(1)
    End With
    
    ' 检查是否选择了文件和保存路径
    If VarType(sourceFilePath) = vbBoolean Or VarType(saveFolderPath) = vbBoolean Then
        MsgBox "未选择文件或保存路径。拆分操作已取消。", vbExclamation
        Exit Sub
    End If
    
    ' 设置要拆分的列
    columnToSplit = InputBox("请输入要拆分的列:(填列号，如：A、B、C)")
    ' 调出输入框对话框并获取用户输入的数据
    'inputValue = InputBox("请输入变量的值:")
    
    ' 检查用户是否点击了取消按钮或没有输入任何内容
    If columnToSplit = "" Then
        MsgBox "未输入任何内容。操作已取消。", vbExclamation
        Exit Sub
    End If
    
    ' 创建一个集合来存储唯一值
    Set uniqueValues = New Collection
    
    ' 打开要拆分的文件
    Set sourceWorkbook = Workbooks.Open(sourceFilePath)
    Set sourceWorksheet = sourceWorkbook.ActiveSheet
    
    ' 获取最后一行
    lastRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnToSplit).End(xlUp).Row
    
    ' 遍历指定列的值，将唯一值添加到集合中
    For i = 2 To lastRow ' 从第二行开始，跳过标题行
        value = sourceWorksheet.Range(columnToSplit & i).value
        
        On Error Resume Next
        uniqueValues.Add value, CStr(value)
        On Error GoTo 0
    Next i
    
    ' 拆分数据并保存到不同的文件中
    For Each value In uniqueValues
        ' 创建新的工作簿并复制数据
        Set targetWorkbook = Workbooks.Add()
        Set targetWorksheet = targetWorkbook.Worksheets(1)
        
        ' 复制标题行
        sourceWorksheet.Rows(1).Copy Destination:=targetWorksheet.Rows(1)
        
        ' 复制匹配的行
        Dim targetRow As Long
        targetRow = 2 ' 第二行开始，跳过标题行
        For i = 2 To lastRow ' 从第二行开始，跳过标题行
            If sourceWorksheet.Range(columnToSplit & i).value = value Then
                sourceWorksheet.Rows(i).Copy Destination:=targetWorksheet.Rows(targetRow)
                targetRow = targetRow + 1
            End If
        Next i
        
        ' 使用指定列的值命名文件
        targetWorkbook.SaveAs saveFolderPath & "\" & value & ".xlsx"
        targetWorkbook.Close SaveChanges:=False
    Next value
    
    ' 关闭源文件
    sourceWorkbook.Close SaveChanges:=False
    
    MsgBox "数据拆分完成。保存路径为：" & saveFolderPath, vbInformation
    MsgBox "文件拆分成功。麻烦请小cai喝水，谢谢！"
End Sub

View Code

　　2、合并：将多个文件、多个表。批量合并Excel文件，并按照第一行的顺序、第一列的值合并

Sub MergeExcelFiles()
    '批量合并Excel文件，并按照第一行的顺序、第一列的值合并
    Dim mergeBook As Workbook
    Dim mergeSheet As Worksheet
    Dim sourceBook As Workbook
    Dim sourceSheet As Worksheet
    Dim sourcePath As String
    Dim file As String
    Dim isFirstFile As Boolean
    Dim headerRange As Range
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim aimsheet As Worksheet
    Dim desktopPath As String
    
    
    
    ' 选择合并文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择合并文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择合并文件夹。合并操作已取消。", vbExclamation
            Exit Sub
        End If
        sourcePath = .SelectedItems(1) & "\"
    End With
    
    ' 选择保存文件的路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存文件路径"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择保存合并文件保存路径。合并操作已取消。", vbExclamation
            Exit Sub
        End If
        desktopPath = .SelectedItems(1) & "\"
    End With
    
    ' 检查是否选择了文件和保存路径
    If VarType(sourceFilePath) = vbBoolean Or VarType(saveFolderPath) = vbBoolean Then
        MsgBox "未选择文件或保存路径。合并操作已取消。", vbExclamation
        Exit Sub
    End If
    
    ' 设置要合并的Excel文件所在的文件夹路径、桌面路径
    'sourcePath = "C:\Users\86130\Desktop\merge\"
    'desktopPath = Environ("USERPROFILE") & "\Desktop\"
    
    ' 创建一个新的Excel文件作为合并后的文件
    Set mergeBook = Workbooks.Add
    Set mergeSheet = mergeBook.Sheets(1)
    
    ' 遍历要合并的Excel文件列表
    file = Dir(sourcePath & "*.xlsx")
    isFirstFile = True
    Do While file <> ""
        ' 打开源Excel文件
        Set sourceBook = Workbooks.Open(sourcePath & file)
        ' 遍历工作表
        For Each sourceSheet In sourceBook.Worksheets
            ' 获取第一个表格的数据范围
            'Set sourceSheet = aimsheet
            Set headerRange = sourceSheet.Rows(1)
            lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
            lastColumn = headerRange.Cells(headerRange.Cells.Count).End(xlToLeft).Column
            
            ' 如果是第一个文件，则直接复制数据到合并后的文件中
            If isFirstFile Then
                sourceSheet.Range(sourceSheet.Cells(1, 1), sourceSheet.Cells(lastRow, lastColumn)).Copy mergeSheet.Cells(1, 1)
                isFirstFile = False
            Else
                ' 否则，根据第一列的值匹配合并
                Dim mergeLastRow As Long
                Dim mergeLastColumn As Long
                mergeLastRow = mergeSheet.Cells(mergeSheet.Rows.Count, 1).End(xlUp).Row
                mergeLastColumn = mergeSheet.Cells(1, mergeSheet.Columns.Count).End(xlToLeft).Column
                
                ' 遍历源数据的每一行
                For i = 2 To lastRow
                    Dim firstColumnValue As String
                    firstColumnValue = sourceSheet.Cells(i, 1).value
                    
                    ' 查找第一列的值在合并后的文件中对应的行位置
                    Dim mergeRow As Range
                    Set mergeRow = mergeSheet.Columns(1).Find(firstColumnValue, LookIn:=xlValues, LookAt:=xlWhole)
                    
                    If Not mergeRow Is Nothing Then
                        ' 第一列的值已存在，遍历第一行中的字段判断是否存在
                        For j = 2 To lastColumn
                            Dim columnName As String
                            columnName = headerRange.Cells(1, j).value
                            
                            Dim columnMatch As Range
                            Set columnMatch = mergeSheet.Rows(1).Find(columnName, LookIn:=xlValues, LookAt:=xlWhole)
                            
                            If Not columnMatch Is Nothing Then
                                ' 字段存在，覆盖数据到对应的单元格
                                mergeSheet.Cells(mergeRow.Row, columnMatch.Column).value = sourceSheet.Cells(i, j).value 'columnMatch改成j
                            Else
                                ' 字段不存在，新增列并插入数据
                                mergeLastColumn = mergeLastColumn + 1
                                mergeSheet.Cells(1, mergeLastColumn).value = columnName
                                mergeSheet.Cells(mergeRow.Row, mergeLastColumn).value = sourceSheet.Cells(i, j).value
                            End If
                        Next j
                    Else
                        ' 第一列的值不存在，新增行并按照第一行的数据顺序合并
                        mergeLastRow = mergeLastRow + 1
                        mergeSheet.Cells(mergeLastRow, 1).value = firstColumnValue
                        
                        ' 在新增行中根据第一行的数据顺序合并数据
                        For j = 2 To lastColumn
                            'Dim columnName As String
                            columnName = headerRange.Cells(1, j).value
                            
                            'Dim columnMatch As Range
                            Set columnMatch = mergeSheet.Rows(1).Find(columnName, LookIn:=xlValues, LookAt:=xlWhole)
                            
                            If Not columnMatch Is Nothing Then
                                ' 在新增行中找到对应的列位置，合并数据
                                mergeSheet.Cells(mergeLastRow, columnMatch.Column).value = sourceSheet.Cells(i, j).value
                            Else
                                ' 在新增行中新增列并插入数据
                                mergeLastColumn = mergeLastColumn + 1
                                mergeSheet.Cells(1, mergeLastColumn).value = columnName
                                mergeSheet.Cells(mergeLastRow, mergeLastColumn).value = sourceSheet.Cells(i, j).value
                            End If
                        Next j
                    End If
                Next i
            End If
        Next sourceSheet 'aimsheet
        
        ' 关闭源Excel文件
        sourceBook.Close SaveChanges:=False
        
        ' 继续处理下一个文件
        file = Dir
    Loop
    
    ' 保存合并后的文件
    mergeBook.SaveAs desktopPath & "merge-File" & Format(Now, "YYYY.M.D-h.m") & ".xlsx"
    
    ' 关闭合并后的文件
    mergeBook.Close SaveChanges:=False
    
    ' 清理对象
    Set mergeSheet = Nothing
    Set mergeBook = Nothing
    MsgBox "合并成功。麻烦请小cai喝水，谢谢！"
    'MsgBox "合并成功。"
End Sub

View Code

　　3、合并：将多个文件多个表的数据合并到一个表中（复制到一个表中，含表名)

Sub MergeExcelTables_many_one_sheet()
    ' 将多个文件多个表的数据合并到一个表中（复制到一个表中，含表名)
    Dim folderPath As String
    Dim filePath As String
    Dim fileName As String
    Dim wbTarget As Workbook
    Dim wbSource As Workbook
    Dim wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim tableRange As Range
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim targetRow As Long
    Dim desktopPath As String
    
     
    ' 选择合并文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择合并文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择合并文件夹。合并操作已取消。", vbExclamation
            Exit Sub
        End If
        folderPath = .SelectedItems(1) & "\"
    End With
    
    ' 选择保存文件的路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存文件路径"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择保存合并文件保存路径。合并操作已取消。", vbExclamation
            Exit Sub
        End If
        desktopPath = .SelectedItems(1) & "\"
    End With
    
    ' 检查是否选择了文件和保存路径
    If VarType(sourceFilePath) = vbBoolean Or VarType(saveFolderPath) = vbBoolean Then
        MsgBox "未选择文件或保存路径。合并操作已取消。", vbExclamation
        Exit Sub
    End If
    
    ' 创建合并后的工作簿
    Set wbTarget = Workbooks.Add
    Set wsTarget = wbTarget.Sheets(1)
    
    ' 设置文件夹路径和桌面路径
    'folderPath = "C:\Users\86130\Desktop\merge-2\" ' 替换为你的文件夹路径
    'desktopPath = Environ("USERPROFILE") & "\Desktop\"
    
    ' 循环处理文件夹中的所有文件
    fileName = Dir(folderPath & "*.xls*")
    Do While fileName <> ""
        ' 打开源工作簿
        filePath = folderPath & fileName
        Set wbSource = Workbooks.Open(filePath)
        
        ' 循环处理源工作簿中的所有表格
        For Each wsSource In wbSource.Worksheets
            ' 查找目标工作表的下一个空行
            lastRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row
            targetRow = lastRow + 1
            
            ' 复制源表格的数据到目标工作表
            lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
            lastColumn = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
            Set tableRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastColumn))
            tableRange.Copy wsTarget.Cells(targetRow, 1)
        Next wsSource
        
        ' 关闭源工作簿
        wbSource.Close SaveChanges:=False
        
        ' 继续处理下一个文件
        fileName = Dir
    Loop
    
    ' 清除剪贴板内容
    Application.CutCopyMode = False
    ' 保存合并后的工作簿到桌面
    wbTarget.SaveAs desktopPath & "MergeExcelTables" & Format(Now, "YYYY.M.D-h.m") & ".xlsx" ' 可根据需要修改文件名
    
    ' 关闭合并后的工作簿
    wbTarget.Close SaveChanges:=False
    
    ' 提示合并完成
    'MsgBox "合并完成。"
    MsgBox "文件合并成功。麻烦请小cai喝水，谢谢！"
End Sub

View Code

　　4、合并：将多个文件多个表的数据合并到一个文件中（一个文件多个表，即合并表)

Sub MergeExcelTables_many_many_sheet()
    ' 将多个文件多个表的数据合并到一个文件中（一个文件多个表，即合并表)
    Dim folderPath As String
    Dim desktopPath As String
    Dim mergedWorkbook As Workbook
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim mergedWorksheet As Worksheet
    Dim file As String
    
      
    ' 选择合并文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择合并文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择合并文件夹。合并操作已取消。", vbExclamation
            Exit Sub
        End If
        folderPath = .SelectedItems(1) & "\"
    End With
    
    ' 选择保存文件的路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存文件路径"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择保存合并文件保存路径。合并操作已取消。", vbExclamation
            Exit Sub
        End If
        desktopPath = .SelectedItems(1) & "\"
    End With
    
    ' 检查是否选择了文件和保存路径
    If VarType(sourceFilePath) = vbBoolean Or VarType(saveFolderPath) = vbBoolean Then
        MsgBox "未选择文件或保存路径。合并操作已取消。", vbExclamation
        Exit Sub
    End If
    
    ' 设置文件夹路径和桌面路径
    'folderPath = "C:\Users\86130\Desktop\merge-2\" ' 将路径更改为你的文件夹路径
    'desktopPath = Environ("USERPROFILE") & "\Desktop\"
    
    ' 创建合并后的工作簿
    Set mergedWorkbook = Workbooks.Add
    Set mergedWorksheet = mergedWorkbook.Sheets(1)
    
    ' 循环遍历文件夹中的每个Excel文件
    file = Dir(folderPath & "*.xlsx") ' 仅处理扩展名为.xlsx的文件，可根据需要修改
    Do While file <> ""
        ' 打开源工作簿
        Set sourceWorkbook = Workbooks.Open(folderPath & file)
        
        ' 循环遍历源工作簿中的每个工作表
        For Each sourceWorksheet In sourceWorkbook.Worksheets
            ' 在合并后的工作簿中创建新的工作表
            mergedWorksheet.Copy after:=mergedWorkbook.Sheets(mergedWorkbook.Sheets.Count)
            Set mergedWorksheet = mergedWorkbook.Sheets(mergedWorkbook.Sheets.Count)
            
            ' 将源工作表的内容复制到合并后的工作表
            sourceWorksheet.UsedRange.Copy mergedWorksheet.Cells(1, 1)
        Next sourceWorksheet
        
        ' 关闭源工作簿，保存更改
        sourceWorkbook.Close SaveChanges:=False
        
        ' 继续处理下一个文件
        file = Dir
    Loop
    
    ' 保存合并后的工作簿到桌面
    mergedWorkbook.SaveAs desktopPath & "MergedWorkbook" & Format(Now, "YYYY.M.D-h.m") & ".xlsx" ' 可根据需要修改文件名
    
    ' 关闭合并后的工作簿
    mergedWorkbook.Close SaveChanges:=False
    
    ' 提示合并完成
    'MsgBox "合并完成！"
    MsgBox "文件合并成功。麻烦请小cai喝水，谢谢！"
End Sub

View Code

标签：Dim,vba,Set,End,文件,Excel,Cells,合并,拆分
From： https://www.cnblogs.com/caidongji/p/17534112.html

vba批量合并and拆分多个Excel文件

相关文章

赞助商

阅读排行