本文主要是介绍合并文件夹内所有Excel文件（目前仅限于合并单层文件夹，如果文件夹下面有文件夹，暂未加入此功能，默认合并所有文件的所有Sheet）优化文件名_变更为：文件夹名字 + 合并的文件-(xls+xlsx)，希望对大家解决编程问题提供一定的参考价值，需要的开发者们随着小编来一起学习吧！
几经修改，终于算是成为自己较为满意的一个VBA程序（2020-6-6修正）
然，因个人才疏学浅，如有疏漏，希望各位前辈多多指正~在下先行谢过~
1、考虑到Excel新建Sheet的命名规则
2、考虑到xls 和 xlsx文件（office2007前后的版本）
3、考虑到子程序会不会对使用者造成误导，所以全部更改为Function
F、考虑到新建Excel的命名优化
5、考虑到隐藏工作表可能会带来的影响，已经提前进行了预处理
6、考虑到同事（使用者）的表格可能存在不规范的情况，合并工作表的时候充分考虑了UsedRange所可能带来的影响
7、考虑到同事（使用者）可能会有别的文件夹合并需求，所以做了用户自己选的文件夹的对话框
8、考虑到有的表格会有是否更新链接的提示，已经在Workbooks.Open()添加了可选参数，忽略提示，并且默认为不更新链接
9、处理之后不会保存对源文件的修改，保留了源文件的完整性~
'合并文件夹内所有Excel文件（目前仅限于合并单层文件夹，如果文件夹下面有文件夹，暂未加入此功能，默认合并所有文件的所有Sheet）
'升级版_优化合并的文件名_命名方式变更为：文件夹名字 + 合并的文件，更方便区分是那个文件夹下面的合并文件 （xls + xlsx文件皆可用）
'合并文件夹内所有Excel文件（目前仅限于合并单层文件夹，如果文件夹下面有文件夹，暂未加入此功能，默认合并所有文件的所有Sheet）
'升级版1.0_优化合并的文件名_命名方式变更为：文件夹名字 + 合并的文件，更方便区分是那个文件夹下面的合并文件，并且将子程序改为Function，不会误导同事操作其他程序
'升级版2.0_优化含有链接文件，默认不更新链接，防止弹窗影响程序运行Sub 合并文件夹内所有文件()Dim myPath$, myFile$, myPath1$, myPath2$, WB As Workbook, new_book As Workbook, yes_no '这个$ 是相当于定义字符串yes_no = MsgBox("兄台，此程序将会合并您稍后选择的文件夹内所有Excel文件" & Chr(13) & "执行过程中，请勿随意操作电脑" & Chr(13) & Chr(13) & " 请确认，是否继续执行", vbYesNo)If yes_no = 7 Then Exit Sub '如果点击否，则取消程序的执行'调用函数，获取用户选择的文件夹，并且在最后加上一个反斜杠，用于下面的文件列表获取myPath2 = ChooseFolder '这里的路径是没有加入最后的"\"的myPath = myPath2 & "\"myPath1 = InStrRev(myPath2, "\") '从右向左查找"\"，返回其所在的位置，返回值是一个数字，但是最后会变成一个字符串，所以定义的时候也定义了一个字符串If myPath1 = 0 ThenmyPath1 = "" '如果找不到"\"，那么就说明用户选择是主硬盘，如：C:\\等，这样就 返回空值ElsemyPath1 = Right(myPath2, Len(myPath2) - myPath1) & "_" '如果不是空值，那么就直接可以使用Right提取，使用最开始没有"\"的myPath2这个变量，End IfmyFile = Dir(myPath & "*.xls*") '依次找寻指定路径中的*.xls，或者xlsx文件Set new_book = Workbooks.Add '创建新增工作簿对象new_book.SaveAs myPath & myPath1 & "Liang_合并后的文件.xlsx" '创建文件Do While myFile <> "" '当指定路径中有文件时进行循环If myFile <> ThisWorkbook.name And myFile <> myPath1 & "Liang_合并后的文件.xlsx" Then '如果我们这个宏文件在需要处理的文件夹之中，这个判断就会跳过下面的操作Set WB = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=0) '打开符合要求的文件，并且如果遇到需要更新链接的时候，默认不更新Call 合并所有工作表WB.Sheets(1).Copy before:=new_book.Sheets(1)WB.Close 0 '不保存关闭文件Debug.Print (myFile)End IfmyFile = Dir '找寻下一个*.xls，或者xlsx文件Loopnew_book.Savenew_book.CloseSet WB = Nothing '释放变量内存Set new_book = Nothing '释放变量内存MsgBox ("兄台，已完成")
End Sub
Public Function ChooseFolder() As String '定义函数，用于下面的调用'定义并新建一个对话框对象Dim dlgOpen As FileDialogSet dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)'如果当前没有对话框显示，就让他弹出对话框If dlgOpen.Show = -1 Then ChooseFolder = dlgOpen.SelectedItems(1)Set dlgOpen = Nothing
End Function
Function name_clear(name As String) As String '定义函数，用于下面的调用，并且返回值Dim arr, aarr = Array(":", "：", "\", "/", "", "*", "[", "]") '这些是创建Sheet时，Excel不允许使用的字符For Each a In arrname = Replace(name, a, "")NextIf Len(name) > 31 Then name = "截断" & Left(name, 29) '同时，创建Sheet的时候，不可以超过31个字符，所以在这里也进行了替换name_clear = name '函数返回值
End Function
Function 合并所有工作表()Dim row_num As Long, column_num As Long, row_num_temp As Long, column_num_temp As Long, row_num_merge As Long, column_num_merge As Long, i As Long, arr() As Long, new_name As String, sht As Worksheetnew_name = ActiveWorkbook.nameDebug.Print (name_clear(new_name))'遍历工作表，取消隐藏工作表，并且删除掉...For Each sht In Worksheets'如果不是显示状态（返回值是0，也可以写为：(xlSheetVisible)），则删除If sht.Visible <> xlSheetVisible Thensht.Visible = xlSheetVisibleApplication.DisplayAlerts = False '删除时不用确认sht.DeleteEnd IfNext'恢复确认，其实很多人不写这一句，作为小程序写不写倒也无所谓的啦，不影响你后面的程序执行，不过如果你的代码很多，流程很长，建议还是写上去，防止预期之外的的错误发生Application.DisplayAlerts = TrueWorksheets.Add.name = name_clear(new_name)ActiveSheet.Move before:=Sheets(1)For i = 2 To Worksheets.Count'忽略隐藏工作表，如果工作表是显示状态，那么返回值是-1(xlSheetHidden)，工作表状态是正常隐藏的话，返回值是0，如果是非常隐藏的话，则是2(xlSheetVeryHidden)Worksheets(i).Activate'UsedRange.row，代表使用的第一个行数，在有空行的时候体现，同理，UsedRange.column，代表使用的第一个列数，在有空列的时候体现'那么使用第一行 + 已使用的行数，这样可以规避顶部/左侧有空行，导致获取已使用行号的数据不符合预期（老赵，如果你看到这里不懂，就自己拆开代码，加上空行空列体会一下）row_num = Worksheets(i).UsedRange.Row + Worksheets(i).UsedRange.Rows.Count - 1column_num = Worksheets(i).UsedRange.Column + Worksheets(i).UsedRange.Columns.Count - 1'如果格式很不规范，那么获取的UsedRange.rows.count就可能是整个表格的行数，所以要规避这种情况，如果相同，就让他减1If row_num = Worksheets(i).Rows.Count Then row_num = row_num - 1If column_num = Worksheets(i).Columns.Count Then column_num = column_num - 1'相当于遍历所有的列，都按ctrl + ↑，取数组的最大值ReDim arr(1 To column_num)For j = LBound(arr) To UBound(arr)row_num_temp = Worksheets(i).Cells(row_num + 1, j).End(xlUp).Rowarr(j) = row_num_tempNextDebug.Print (Application.WorksheetFunction.Max(arr))row_num_temp = Application.WorksheetFunction.Max(arr) '赋予最大值，确定最大的有数据的行数'相当于遍历所有的行，都按ctrl + ←，取数组的最大值'Erase arr 清空数组，但是也可以不用，直接用ReDim也可以，如果要保留数组内容，需要加一个preserveReDim arr(1 To row_num_temp)For j = LBound(arr) To UBound(arr)column_num_temp = Worksheets(i).Cells(j, column_num + 1).End(xlToLeft).Columnarr(j) = column_num_tempNextDebug.Print (Application.WorksheetFunction.Max(arr))column_num_temp = Application.WorksheetFunction.Max(arr) '赋予最大值，确定最大的有数据的列数Worksheets(i).Range(Cells(1, 1), Cells(row_num_temp, column_num_temp)).SelectSelection.Copy Sheets(1).Cells(row_num_merge + 1, 2)Worksheets(1).Cells(row_num_merge + 1, 1) = Worksheets(i).namerow_num_merge = Sheets(1).UsedRange.Rows.CountNext'将首行标题转为所有行（选择空值，=上面的数据）Worksheets(1).ActivateColumns("A:A").SelectSelection.SpecialCells(xlCellTypeBlanks).SelectApplication.CutCopyMode = FalseSelection.FormulaR1C1 = "=R[-1]C"Columns("A:A").SelectSelection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=FalseApplication.CutCopyMode = FalseRange("A1").Select
End Function
这篇关于合并文件夹内所有Excel文件（目前仅限于合并单层文件夹，如果文件夹下面有文件夹，暂未加入此功能，默认合并所有文件的所有Sheet）优化文件名_变更为：文件夹名字 + 合并的文件-(xls+xlsx)的文章就介绍到这儿，希望我们推荐的文章对编程师们有所帮助！
