Question

我有下面提到的代码，用于将excel文件合并到一个包含多个工作表的工作簿中。它完美地运作。我想要一些帮助，为这段代码添加“浏览文件夹”功能。因此，该用户可以选择包含源工作簿的文件夹。请帮忙。

Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFileName As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Jude" ' change to suit
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFileName = Dir(MyPath & "\*.xlsx", vbNormal)



If Len(strFileName) = 0 Then Exit Sub

Do Until strFileName = ""

        Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFileName)

        Set wsSrc = wbSrc.Worksheets(1)

        wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

        wbDst.Worksheets(wbDst.Worksheets.Count).Name = strFileName

       wbSrc.Close False

    strFileName = Dir()

Loop
wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

我尝试了下面的代码。但它给出了错误。请看。

Function GetFolder(strPath As String, fldSt As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = fldSt
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub Getsheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFileName As String


Path = GetFolder("C:\", "Select an Input Folder") & Application.PathSeparator

Set wbDst = Workbooks.Add(xlWBATWorksheet)

strFileName = Dir(Path & "*.xls?")

Do While Filename <> ""

        Set wbSrc = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)

        Set wsSrc = wbSrc.Worksheets(1)

        wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

        wbDst.Worksheets(wbDst.Worksheets.Count).Name = strFileName

       wbSrc.Close False

    strFileName = Dir()

Loop

wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Answer 1

包括：

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

然后在子

中

MyPath = GetFolder

替代：

MyPath = "C:\Jude" ' change to suit

添加＆＃34;浏览文件夹＆＃39;合并宏的选项

1 个答案: