[發問] FileDialog(msoFileDialogFilePicker) 開啟指定檔案

mdr0465

各位大大你好

以下的程式是在網上找到的, 用途是在開啟一個excel 檔案之後執行以下程式, 可以彈出一個選框架可以自行任意選取某一個excel 檔案並複製所有工作表到現在打開的excel file,

當選取檔案後就不能複製工作表, 請幫忙看看指點程式問題在那里, 謝謝





Sub test()
Dim FName As String, FPath As String
Dim sheet As Worksheet
Dim FDialog As FileDialog

Application.ScreenUpdating = False


Set FDialog = Application.FileDialog(msoFileDialogFilePicker)

If FDialog.Show = -1 Then
    FPath = FDialog.SelectedItems(1)
End If


'FName = Dir(FPath & "\*.xlsx*")

Do While FPath <> ""
    Workbooks.Open Filename:=FPath, ReadOnly:=True
    For Each sheet In ActiveWorkbook.Sheets
        sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next sheet
Workbooks(FPath).Close
Loop

Application.ScreenUpdating = True


End Sub

samwang

回復 1# mdr0465

請測試看看，謝謝。

Sub test()
Dim FName As String, FPath As String
Dim sheet As Worksheet
Dim FDialog As FileDialog

Application.ScreenUpdating = False
Application.DisplayAlerts = False ' 關閉警告訊息
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
If FDialog.Show = -1 Then
     FPath = FDialog.SelectedItems(1)
End If

Do While FPath <> ""
    Set WB = Workbooks.Open(FPath)
    For Each sheet In ActiveWorkbook.Sheets
        sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next sheet
    WB.Close
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

mdr0465

回復 2# samwang


    samwang謝謝你的回覆,
但當我在一個文件夾里有幾個excel檔,我選取了某一個檔案的時候,它運行程式時,會不停複製被選取的檔案里的工作表沒有停止,請問應怎樣改呢?
 
謝謝

samwang

回復 3# mdr0465

請再測試看看，謝謝。

Sub test2()
Dim FName As String, FPath As String
Dim sheet As Worksheet
Dim FDialog As FileDialog

Application.ScreenUpdating = False
Application.DisplayAlerts = False ' 關閉警告訊息
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
If FDialog.Show = -1 Then
     FPath = FDialog.SelectedItems(1)
End If

For x = 1 To FDialog.SelectedItems.Count
    Set WB = Workbooks.Open(FPath)
    For Each sheet In ActiveWorkbook.Sheets
        sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next sheet
    WB.Close
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

samwang

回復 3# mdr0465


不好意思，4樓的程式有問題，以此為主(可以同時複選擇多個excel)，謝謝

Sub test()
Dim FName As String, FPath As String
Dim sheet As Worksheet
Dim FDialog As FileDialog

Application.ScreenUpdating = False
Application.DisplayAlerts = False ' 關閉警告訊息
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
FDialog.Show

For x = 1 To FDialog.SelectedItems.Count
    FPath = FDialog.SelectedItems(x)
    Set WB = Workbooks.Open(FPath)
    For Each sheet In ActiveWorkbook.Sheets
        sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next sheet
    WB.Close
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

mdr0465

回復 5# samwang

    samwang 謝謝你再次的回覆,
程式可以運行了, 萬分感謝你

謝謝