Lấy giá trị của Worksheet từ Folder và SubFolder

[quyenpv]

Em chào các anh chị trên diễn đàn!
Lâu ngày em lại nhờ anh chị sửa giúp code em đang dùng lấy giá trị của file đang đóng từ Folder, nay phát sinh thêm em muốn lấy cả SubFolder mà code em không lấy được mong anh chị xem và điều chỉnh giúp em với ạ
Khi chạy Code

Hình ảnh 1: Là code em đang chạy chỉ lấy được giá trị trong Folder

Hình ảnh 2: Là mong muốn lấy được cả SubFolder

Option Explicit
Sub ImportWorksheets()
    Dim sFile       As String
    Dim wsTarget    As Worksheet
    Dim wbSource    As Workbook
    Dim wsSource    As Worksheet
    Dim sht         As Worksheet
    Dim shtName     As String
    Dim LRow        As Integer
    Dim FOLDER_PATH As String
    Dim rowTarget   As Long
    'Lay thu muc can thuc hien
    FOLDER_PATH = GetFolder("") & "\"
    Debug.Print FOLDER_PATH
    'Thu muc can Check
    shtName = InputBox(Prompt:="Enter the sheet name", Title:="Search Sheet")
    rowTarget = 2
    'Kiem tra duong dan thu muc chon co hop le khong
    If Not FileFolderExists(FOLDER_PATH) Then
        MsgBox "Specified folder does not exist, exiting!"
        Exit Sub
    End If
    On Error GoTo errHandler
    Application.ScreenUpdating = False
    'Doi ten Worksheet neu thay doi
    Set wsTarget = Sheets("Sheet1")
    'loop through the Excel files in the folder
    sFile = Dir(FOLDER_PATH & "*.xls*")
    Do Until sFile = ""
        'Mo file va chon Worksheet nguon
        Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
        For Each sht In wbSource.Worksheets
            If sht.Name = shtName Then
                Set wsSource = wbSource.Sheets(shtName)
                'Lay du lieu dong cuoi cung
                LRow = wsSource.Range("E" & wsSource.Rows.Count).End(xlUp).Row
                'Lay thong tin data
                With wsTarget
                    .Range("A" & rowTarget).Value = wsSource.Range("E" & LRow).Value
                    .Range("B" & rowTarget).Formula = "=HYPERLINK(""" & FOLDER_PATH & sFile & """,""Click Open File"")"
                    .Range("B" & rowTarget).Font.Underline = False
                End With
                rowTarget = rowTarget + 1
                '            Else
                '                MsgBox "No! " & shtName & " Khong co trong File " & sFile, vbCritical, "Not Found"
            End If
        Next sht
        wbSource.Close SaveChanges:=False
        sFile = Dir()
    Loop
errHandler:
    On Error Resume Next
    Application.ScreenUpdating = True

    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Function GetFolder(strPath As String) As String
    Dim fldr        As FileDialog
    Dim sItem       As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

 

[huhumalu]

Bạn không thử nghiên cứu FSO xem sao, nhìn code giờ lười đọc quá.
Theo mình duyệt file và folder thì nên dùng FSO quản lý sẽ nhẹ nhàng hơn. cho phép truy xuất theo đuôi mở rộng và quét Sub folder cho bạn .

sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "C:\"
    '--> Đổi đường dẫn hoặc dùng Application.FileDialog(msoFileDialogFolderPicker) để lấy FOLDER_PATH'

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
end  sub

Sub DoFolder(Folder)
    Dim SubFolder
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
        ' Duyệt Sub Folder và đệ quy duyệt cả Sub của Sub :D'
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file'
        strFileName = File.Name
        strFilePath = File.Path
       strFileExt = objFSO.GetExtensionName(File)
        ' Đưa sub con để trích xuất dữ liệu vào đây.'
        'if strFileExt = "xls" ....
    Next
End Sub

Tham khảo thêm bài của anh Quang Hải

Tổng quan về FileSystemObject

Nhằm mục đích giúp cho các bạn mới và đang tự học lập trình trong Excel, tôi xin tóm tắt các khái niệm và ứng dụng phổ thông nhất về công cụ FileSystemObject. 1. FileSystemObject là gì? FSO là 1 công cụ mạnh chuyên dùng để xử lý các vấn đề liên quan đến Drive, Folders và Files. Bài viết này chủ...

www.giaiphapexcel.com

 

[quyenpv]

Bạn không thử nghiên cứu FSO xem sao, nhìn code giờ lười đọc quá.
Theo mình duyệt file và folder thì nên dùng FSO quản lý sẽ nhẹ nhàng hơn. cho phép truy xuất theo đuôi mở rộng và quét Sub folder cho bạn .

sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "C:\"
    '--> Đổi đường dẫn hoặc dùng Application.FileDialog(msoFileDialogFolderPicker) để lấy FOLDER_PATH'

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
end  sub

Sub DoFolder(Folder)
    Dim SubFolder
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
        ' Duyệt Sub Folder và đệ quy duyệt cả Sub của Sub :D'
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file'
        strFileName = File.Name
        strFilePath = File.Path
       strFileExt = objFSO.GetExtensionName(File)
        ' Đưa sub con để trích xuất dữ liệu vào đây.'
        'if strFileExt = "xls" ....
    Next
End Sub

Tham khảo thêm bài của anh Quang Hải

Tổng quan về FileSystemObject

Nhằm mục đích giúp cho các bạn mới và đang tự học lập trình trong Excel, tôi xin tóm tắt các khái niệm và ứng dụng phổ thông nhất về công cụ FileSystemObject. 1. FileSystemObject là gì? FSO là 1 công cụ mạnh chuyên dùng để xử lý các vấn đề liên quan đến Drive, Folders và Files. Bài viết này chủ...

www.giaiphapexcel.com

Dạ phương pháp đệ quy này khó thiệt luôn anh, không biết đưa code của em vào như thế nào được ạ

 

[quyenpv]

Em đã tham khảo và chỉnh sửa như này, các anh xem giúp em có lỗi hay tối ưu giúp em với nhé. Tạm thời code chạy đúng yêu cầu mình cần ạ
Cho em hỏi thêm khi mình tạo Hyperlink đến file có cách nào khi click vào nó sẽ mở file và nhảy đến giá trị được liên kết không ạ
Em cám ơn

Sub GetFolder_Data_Collection()
    Dim colFiles    As Collection
    Dim sFile, strPath As String
    Dim wsTarget    As Worksheet
    Dim wbSource    As Workbook
    Dim wsSource    As Worksheet
    Dim sht         As Worksheet
    Dim shtName     As String
    Dim LRow        As Integer
    Dim rowTarget   As Long
    Set wsTarget = Sheets("Sheet1")
    strPath = GetFolder
    Set colFiles = GetFileMatches(strPath, "*.xls*", True)
    With wsTarget
        .Range("A:L").ClearContents
        .Range("A1").Resize(1, 5).Value = Array("Name", "Path", "Cell", "Value", "Numberformat")
        'Set rowTarget = .Rows(2)
    End With
    'Thu muc can Check
    shtName = InputBox(Prompt:="Enter the sheet name", Title:="Search Sheet")
    rowTarget = 2
    For Each sFile In colFiles
        Set wbSource = Workbooks.Open(sFile)
        For Each sht In wbSource.Worksheets
            If sht.Name = shtName Then
                Set wsSource = wbSource.Sheets(shtName)
                'Lay du lieu dong cuoi cung
                LRow = wsSource.Range("E" & wsSource.Rows.Count).End(xlUp).Row
                'Lay thong tin data
                With wsTarget
                    .Range("A" & rowTarget).Value = wsSource.Range("E" & LRow).Value
                    .Range("B" & rowTarget).Formula = "=HYPERLINK(""" & sFile & """,""Click Open File"")"
                    .Range("B" & rowTarget).Font.Underline = False
                End With
                rowTarget = rowTarget + 1
            Else
                Exit For
            End If
        Next sht
        wbSource.Close False
    Next sFile
End Sub

Function GetFileMatches(startFolder As String, filePattern As String, _
        Optional subFolders As Boolean = True) As Collection
    Dim fso, fldr, f, subFldr
    Dim colFiles    As New Collection
    Dim colSub      As New Collection
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    Do While colSub.Count > 0
        Set fldr = fso.GetFolder(colSub(1))
        colSub.Remove 1
        For Each f In fldr.Files
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set GetFileMatches = colFiles
End Function
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