合并文件夹内所有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 Then
        myPath1 = ""    '如果找不到"\"，那么就说明用户选择是主硬盘，如：C:\\等，这样就 返回空值
    Else
        myPath1 = Right(myPath2, Len(myPath2) - myPath1) & "_" '如果不是空值，那么就直接可以使用Right提取，使用最开始没有"\"的myPath2这个变量，
    End If
    
    myFile = 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 If
        myFile = Dir '找寻下一个*.xls，或者xlsx文件
    Loop
    new_book.Save
    new_book.Close
    Set WB = Nothing    '释放变量内存
    Set new_book = Nothing    '释放变量内存
    MsgBox ("兄台，已完成")
End Sub
Public Function ChooseFolder() As String    '定义函数，用于下面的调用
    '定义并新建一个对话框对象
    Dim dlgOpen As FileDialog
    Set 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, a
    arr = Array(":", "：", "\", "/", "", "*", "[", "]")    '这些是创建Sheet时，Excel不允许使用的字符
    For Each a In arr
        name = Replace(name, a, "")
    Next
    If 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 Worksheet
    new_name = ActiveWorkbook.name
    Debug.Print (name_clear(new_name))
    '遍历工作表，取消隐藏工作表，并且删除掉...
    For Each sht In Worksheets
        '如果不是显示状态（返回值是0，也可以写为：(xlSheetVisible)），则删除
        If sht.Visible <> xlSheetVisible Then
            sht.Visible = xlSheetVisible
            Application.DisplayAlerts = False    '删除时不用确认
            sht.Delete
        End If
    Next
    '恢复确认，其实很多人不写这一句，作为小程序写不写倒也无所谓的啦，不影响你后面的程序执行，不过如果你的代码很多，流程很长，建议还是写上去，防止预期之外的的错误发生
    Application.DisplayAlerts = True
    
    Worksheets.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 - 1
        column_num = Worksheets(i).UsedRange.Column + Worksheets(i).UsedRange.Columns.Count - 1
        '如果格式很不规范，那么获取的UsedRange.rows.count就可能是整个表格的行数，所以要规避这种情况，如果相同，就让他减1
        If row_num = Worksheets(i).Rows.Count Then row_num = row_num - 1
        If 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).Row
            arr(j) = row_num_temp
        Next
        Debug.Print (Application.WorksheetFunction.Max(arr))
        row_num_temp = Application.WorksheetFunction.Max(arr) '赋予最大值，确定最大的有数据的行数
        
        '相当于遍历所有的行，都按ctrl + ←，取数组的最大值
        'Erase arr 清空数组，但是也可以不用，直接用ReDim也可以，如果要保留数组内容，需要加一个preserve
        ReDim 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).Column
            arr(j) = column_num_temp
        Next
        Debug.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)).Select
        Selection.Copy Sheets(1).Cells(row_num_merge + 1, 2)
        Worksheets(1).Cells(row_num_merge + 1, 1) = Worksheets(i).name
        row_num_merge = Sheets(1).UsedRange.Rows.Count
    Next
    '将首行标题转为所有行（选择空值，=上面的数据）
    Worksheets(1).Activate
    Columns("A:A").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Application.CutCopyMode = False
    Selection.FormulaR1C1 = "=R[-1]C"
    Columns("A:A").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select
End Function