[已解决]将代码修改可以自动选择文件夹包括子文件夹下的所有文件

果冻的心

Sub xiugai()
Application.ScreenUpdating = False
Dim Ph, Myfile
Ph = ThisWorkbook.Path & "\需解决" '文档存放位置
Myfile = Dir(Ph & "\*.*")
Do While Myfile <> ""
Set wb = Workbooks.Open(Ph & "\" & Myfile)
With wb.Sheets("表三甲")
     rw = .Range("e10000").End(xlUp).Row
    .Range("e7:e" & rw).Copy .Range("k7:k" & rw)
End With
Debug.Print wb.Name
wb.Close True
Myfile = Dir
Loop
Application.ScreenUpdating = True

End Sub


PS：代码是本网站人员给实现的，在此感谢

最佳答案

月排行榜 / 总排行榜

zjdh

2022-5-16 18:27

Sub TEXT()
    Set Mypath = CreateObject("Shell.Application").BrowseForFolder(0, "请选择希望操作的文件夹：", &H1)
    If Not Mypath Is Nothing Then
        Ph = Mypath.self.Path & "\"
    End If
    Application.ScreenUpdating = False
    Myfile = Dir(Ph & "\*.*")
    Do While Myfile <> ""
        Set wb = Workbooks.Open(Ph & "\" & Myfile)
        With wb.Sheets("表三甲")
            rw = .Range("E10000").End(xlUp).Row
            .Range("E7:E" & rw).Copy .Range("K7:K" & rw)
        End With
        wb.Close True
        Myfile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

果冻的心

顶一下

果冻的心

自己已经解决

zjdh

Sub TEXT()
    Set Mypath = CreateObject("Shell.Application").BrowseForFolder(0, "请选择希望操作的文件夹：", &H1)
    If Not Mypath Is Nothing Then
        Ph = Mypath.self.Path & "\"
    End If
    Application.ScreenUpdating = False
    Myfile = Dir(Ph & "\*.*")
    Do While Myfile <> ""
        Set wb = Workbooks.Open(Ph & "\" & Myfile)
        With wb.Sheets("表三甲")
            rw = .Range("E10000").End(xlUp).Row
            .Range("E7:E" & rw).Copy .Range("K7:K" & rw)
        End With
        wb.Close True
        Myfile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub