1、拆分:一个文件按照某一列的类型,拆分成多个文件:
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
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
2、合并:将多个文件、多个表。批量合并Excel文件,并按照第一行的顺序、第一列的值合并
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
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
3、合并:将多个文件多个表的数据合并到一个表中(复制到一个表中,含表名)
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
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
4、合并:将多个文件多个表的数据合并到一个文件中(一个文件多个表,即合并表)
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
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