ขอความช่วยเหลือในเรื่องการใช้ VBA เลือกเฉพาะไฟล์นั้นๆ เพื่อนำมารวบรวมข้อมูลต่อ

[clearwipe01]

01. Check error data Consolidation - Jan' 22.xlsm

สวัสดี พี่ๆทุกท่านครับ
ผมขอรบกวนสอบถามพี่ๆทุกท่านหน่อยครับ
พอดีผมลองทำเขียน VBA ที่ให้สามารถเลือกไฟล์ในเครื่องได้โดยเลือกแบบเป็นไฟล์ Excel.xlsx
แล้วอยากให้เลือกแค่ไฟล์นั้น(ที่ต้องใช้)จากโฟลเดอร์ที่มีหลายไฟล์ Excel รวมกัน
แต่ผมเขียนโค้ดให้มันอ่าน(ก็อปปี้)เฉพาะไฟล์นั้นและรวบรวมไฟล์นั้นไม่เป็นครับ
จึงอยากขอความช่วยเหลือพี่ๆทุกท่านหน่อยครับ
ขอบคุณครับ

Code: Select all

Sub GetSheets()
' Collect Sheets by browse folder directory
Dim Get_Path As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogFilePicker)
     Clicked = .Show
        If Clicked = 0 Then 'The Cancel button or the X is clicked.
            Exit Sub
        ElseIf Clicked <> 0 Then ' if OK is pressed
            Get_Path = .SelectedItems(1) & "\"
        End If
Path = Get_File
End With
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub GetSheets()
    ' Collect Sheets by browse folder directory
    Dim Get_Path As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '    With Application.FileDialog(msoFileDialogFilePicker)
    '     Clicked = .Show
    '        If Clicked = 0 Then 'The Cancel button or the X is clicked.
    '            Exit Sub
    '        ElseIf Clicked <> 0 Then ' if OK is pressed
    '            Get_Path = .SelectedItems(1) & "\"
    '        End If
    'Path = Get_File
    'End With
    'Filename = Dir(Path & "*.xlsx")
    'Do While Filename <> ""
    Get_Path = Application.GetOpenFilename("Excel file(*.xls*),*.xls*")
    If Get_Path = "False" Then Exit Sub
    Workbooks.Open Filename:=Get_Path, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next Sheet
    Workbooks(VBA.Split(Get_Path, "\")(UBound(VBA.Split(Get_Path, "\")))).Close
    'Filename = Dir()
    'Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

[clearwipe01]

ขอบพระคุณอย่างสูงครับ อาจารย์ ใช้งานได้ตามแบบที่ต้องการเลยครับ
ขอบคุณครับ

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub GetSheets()
    ' Collect Sheets by browse folder directory
    Dim Get_Path As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '    With Application.FileDialog(msoFileDialogFilePicker)
    '     Clicked = .Show
    '        If Clicked = 0 Then 'The Cancel button or the X is clicked.
    '            Exit Sub
    '        ElseIf Clicked <> 0 Then ' if OK is pressed
    '            Get_Path = .SelectedItems(1) & "\"
    '        End If
    'Path = Get_File
    'End With
    'Filename = Dir(Path & "*.xlsx")
    'Do While Filename <> ""
    Get_Path = Application.GetOpenFilename("Excel file(*.xls*),*.xls*")
    If Get_Path = "False" Then Exit Sub
    Workbooks.Open Filename:=Get_Path, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next Sheet
    Workbooks(VBA.Split(Get_Path, "\")(UBound(VBA.Split(Get_Path, "\")))).Close
    'Filename = Dir()
    'Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub