求助修改代码

huaichuan1

Sub 合并当前目录下所有工作簿的全部工作表至一个工作簿中()
Dim mypath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
mypath = ActiveWorkbook.Path
MyName = Dir(mypath & "\" & "*.doc*")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(mypath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("a65536").End(xlUp).Row + 1, 1) = Left(MyName, Len(MyName) - 4) 'row+1不留空行
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("a65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & WbN, vbInformation, "提示"
End Sub
求助大神求改代码，使其可以手动选择文件夹。现在代码是只能在同一文件夹下。

liulang0808

mypath = ActiveWorkbook.Path
修改如下看看   
With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应文本夹"
        If .Show Then mypath= .SelectedItems(1) Else Exit Sub '
    End With

huaichuan1

Sub 合并当前目录下所有工作簿的全部工作表至一个工作簿中()  
  
    ' 声明变量  
    Dim mypath As String, MyName As String, AWbName As String  
    Dim Wb As Workbook, WbN As String  
    Dim G As Long  
    Dim Num As Long  
    Dim BOX As String  
    Dim WbDest As Workbook ' 目标工作簿，需要声明这个变量  
  
    ' 设置目标工作簿为当前活动工作簿  
    Set WbDest = ActiveWorkbook  
  
    ' 允许用户选择一个文件夹  
    With Application.FileDialog(msoFileDialogFolderPicker)  
        .Show  
        ' 如果没有选择文件夹，则显示消息框并退出子程序  
        If .SelectedItems.Count = 0 Then  
            MsgBox "未选择文件夹，操作已取消。", vbExclamation  
            Exit Sub  
        End If  
        mypath = .SelectedItems(1) ' 获取选择的文件夹路径  
    End With  
  
    ' 关闭屏幕更新以提高性能  
    Application.ScreenUpdating = False  
  
    ' 初始化变量  
    MyName = Dir(mypath & "\" & "*.xls*") ' 搜索指定路径下的所有 Excel 文件（包括 .xls 和 .xlsx）  
    AWbName = ActiveWorkbook.Name ' 获取当前活动工作簿的名称  
    Num = 0 ' 初始化已合并的工作簿数量  
    WbN = "" ' 初始化已合并的工作簿名称字符串  
  
    ' 循环遍历指定文件夹下的所有 Excel 文件  
    Do While MyName <> ""  
        If MyName <> AWbName Then ' 跳过当前活动工作簿，避免自我复制  
            ' 打开找到的工作簿  
            Set Wb = Workbooks.Open(mypath & "\" & MyName)  
            Num = Num + 1 ' 增加已合并的工作簿数量  
            ' 在目标工作簿的当前活动工作表（默认是第一个工作表）中粘贴数据  
            With WbDest.ActiveSheet ' 注意这里应该明确指定目标工作簿的活动工作表，而不是 Workbooks(1).ActiveSheet  
                ' 在当前活动工作表的最后一个数据行下方插入源工作簿的名称（不包含文件扩展名）  
                .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Value = Left(MyName, Len(MyName) - 4)   
                ' 循环遍历源工作簿的所有工作表，并将其内容复制到目标工作簿的当前活动工作表中  
                For G = 1 To Wb.Sheets.Count  
                    Wb.Sheets(G).UsedRange.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)  
                Next G  
                WbN = WbN & Chr(13) & Wb.Name ' 在已合并的工作簿名称字符串中添加新工作簿的名称和换行符  
                Wb.Close False ' 关闭源工作簿，不保存更改  
            End With  
        End If  
        ' 查找下一个 Excel 文件  
        MyName = Dir  
    Loop  
  
    ' 选中目标工作簿的第一个单元格，以便用户可以看到合并后的数据  
    WbDest.ActiveSheet.Range("A1").Select  
  
    ' 重新启用屏幕更新  
    Application.ScreenUpdating = True  
  
    ' 显示消息框，告知用户已合并的工作簿数量和名称  
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & WbN, vbInformation, "提示"  
  
End Sub
用了AI改写了，分享给大伙吧，*.xls*"这里改成doc就是合并word文件。

huaichuan1

liulang0808 发表于 2024-4-25 13:51
mypath = ActiveWorkbook.Path
修改如下看看   
With Application.FileDialog(msoFileDialogFolderPicke ...

感谢大佬，我用ai已经改了，还在审核没发出来。您这个也可以

huaichuan1

liulang0808 发表于 2024-4-25 13:51
mypath = ActiveWorkbook.Path
修改如下看看   
With Application.FileDialog(msoFileDialogFolderPicke ...

大佬还有个问题
Sub 提取文件名不区分后缀指定文件夹()  
  
    Dim mypath$, Fs$, ARR1(1 To 100, 1 To 2), k%  
    Dim folderBrowser As FileDialog  
      
    ' 创建一个 FileDialog 对象作为文件夹浏览器  
    Set folderBrowser = Application.FileDialog(msoFileDialogFolderPicker)  
      
    ' 显示文件夹浏览器对话框，并让用户选择一个文件夹  
    If folderBrowser.Show = -1 Then  
        mypath = folderBrowser.SelectedItems(1) & "\"  
    Else  
        Exit Sub ' 如果没有选择文件夹，则退出子程序  
    End If  
      
    ' 使用用户选择的路径来获取文件名  
    Fs = Dir(mypath & "*.*")  
      
    k = 0 ' 初始化计数器  
    Do  
        k = k + 1  
        ARR1(k, 1) = k  
        ARR1(k, 2) = Fs  
        Fs = Dir() ' 获取下一个文件名  
    Loop While Fs <> ""  
      
    ' 输出结果到工作表  
    Sheets(1).Activate  
    [b2] = "序号"  
    [c2] = "文件名"  
    Range("a1").CurrentRegion.Offset(2).ClearContents ' 清除旧数据  
    [a3].Resize(k, 2).Value = ARR1  
      
End Sub
如何按照win10的显示顺序提取文件？ 提取的文件名 总是10在第一个