Tổng Hợp N + 1 Files Trong Folder Không Sử Dụng ADO, DAO và Workbooks.Open

Chia sẻ bởi:hands
★★★★★
‹ So sánh 3 cách lấy dữ liệu... Dùng Macro 4 để lấy dữ liệu... ›
Quảng cáo

Xuất phát từ ý tưởng ở 2 thớt sau:

https://www.giaiphapexcel.com/forum/showthread.php?115460-Tr%C3%ADch-xu%E1%BA%A5t-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-kh%C3%A1c-nhau-v%C3%A0o-file-t%E1%BB%95ng-h%E1%BB%A3p

https://www.giaiphapexcel.com/forum/showthread.php?114698-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-file-excel-%C4%91ang-%C4%91%C3%B3ng-b%E1%BA%B1ng-ADO&p=719556#post719556

Mạnh lập thớt này để nghiên cứu học tập thêm và sau đó là trả bài cho Bạn [URL="https://www.giaiphapexcel.com/forum/member.php?189279-doveandrose"]doveandrose
sau một thời gian mạnh Theo [URL="https://www.giaiphapexcel.com/forum/member.php?189279-doveandrose"]doveandrose hoc code ….

I/ Như tiều đề của thớt này ta sẻ tổng hợp tất cả các Files trong Folder mà không xác định tên File, tổng số File có bao nhiêu trong Folder chơi hêt ….*.xls, *.xlsb,*.xlsx ….

1/ Tên Sheets("THA") là tên Sheet cần tổng hợp

2/ Vùng dữ liệu cần tổng hợp là

3/ Lấy hết lên gán lên File tổng hợp nối tiếp xuống

II/ Xong câu I ta chuyển qua câu II

1/ vẫn như tiêu đề ta sẻ tổng hợp file có Pass Open lấy dữ liệu của 1 Files mà biết:

1/ Tên Sheets("THA") là tên Sheet cần tổng hợp

2/ Vùng dữ liệu cần tổng hợp là

3/ Pass Open là: 1

4/ lấy hết lên gán lên File tổng hợp

Câu này có 2 cách : 1 là nhập pass = tay , 2 là cho pass vào code luôn….Ai thích kiểu nào ta chơi kiểu đó …

Xin mời các Bạn có nhả hứng tham gia một tí cho vui ….sau đó Mạnh sẻ úp đáp án trả Bài cho Thầy [URL="https://www.giaiphapexcel.com/forum/member.php?189279-doveandrose"]doveandrose ….Vì đã nghiên cứ từ những thuất toán của thầy ….
–=0|||||–=0!$@!!

Files giả lập kèm theo

Sau đó nữa nếu nổi gió lên ta chơi tiếp các kiểu …_+)(9 -.,;

Xin cảm ơn

Làm vầy cũng không vi phạm điều kiện. Nhưng dữ liệu lớn thì không ổn.
Sub GetData()
Const ExcelExtension As String = "|xls|xlsb|xlsm|xlsx|"
Dim i As Long, sFolder As String, iFile As Object
With CreateObject("Scripting.FileSystemObject")
sFolder = .GetParentFolderName(ThisWorkbook.FullName)
For Each iFile In .GetFolder(sFolder).Files
If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
With Sheets(1).Cells(i * 87 + 1, 1).Resize(87, 13)
.FormulaArray = "='" & sFolder & "THA'!A14:M100"
.Value = .Value
End With
i = i + 1
End If
End If
Next
End With
End Sub

www.giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-h%E1%BB%A3p-n-1-files-trong-folder-kh%C3%B4ng-s%E1%BB%AD-d%E1%BB%A5ng-ado-dao-v%C3%A0-workbooks-open.115535/

Xây dựng Lương 3P, KPI cho Doanh nghiệp
Khóa học SprinGO phù hợp

Xây dựng Lương 3P, KPI cho Doanh nghiệp

Làm thế nào để trả lương cho nhân viên chính xác nhất? Đây là một trong những câu hỏi khó trong quản trị nhân...

Xem khóa học
★★★★★ 5 ★ 1 👤 2 ▥ 0
‹ So sánh 3 cách lấy dữ liệu từ... Dùng Macro 4 để lấy dữ liệu từ... ›
Quảng cáo

Bạn nên đọc

2 Responses

  1. hands says:
    19/01/2023 at 1:31 pm

    sao mình chạy code nó không thấy nhúc nhíc là sao ta…

    Tác giả thớt xem code trên gán dữ liệu vào sheets thứ mấy vậy…và file tổng hợp của tác giả thớt này có mấy sheets vậy nhỉ?….có cái sheet siêu ẩn ẩn ẩn…í–=0–=0–=0 Nhưng mà code trên vẫn chưa làm được cái bạn Kiều Mạnh mong muốn…

    Mình sửa lại code của bạn huuthang_bd ở #2 một chút xem có được không bác kieumanh. Mong cách khác của bác kieumanh.

    Sub GetData()
Const ExcelExtension As String = "|xls|xlsb|xlsm|xlsx|"
Dim i As Long, sFolder As String, iFile As Object
With CreateObject("Scripting.FileSystemObject")
    sFolder = .GetParentFolderName(ThisWorkbook.FullName)
    For Each iFile In .GetFolder(sFolder).Files
        If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
            If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                With Sheet1.Range("A" & (i * 10 + 1) & ":M" & (i * 10 + 10))
                   .FormulaArray = "='" & sFolder & "[" & iFile.Name & "]THA'!A4:M13"
                   .Value = .Value
                End With
                i = i + 1
            End If
        End If
    Next
End With
End Sub

    Mong cách khác của bác kieumanh.

    Lỡ như dữ liệu không liên tục & hàng cuối bất kỳ thì sao nhỉ? Sửa lại theo cái mà anh Kiều Mạnh nói học được từ thầy "Chim Hồng" nè…haha………Kiều Mạnh mà không biết chiu này của anh "Chim Hồng" thì mình …luôn

    Sub GetData()
Const ExcelExtension As String = "|xls|xlsb|xlsm|xlsx|"
Dim i As Long, sFolder As String, iFile As Object, FullPath As String
With CreateObject("Scripting.FileSystemObject")
    sFolder = .GetParentFolderName(ThisWorkbook.FullName)
    i = 4
    Sheets("TongHop").UsedRange.Clear
    For Each iFile In .GetFolder(sFolder).Files
        If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
            If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
            FullPath = "'" & sFolder & "[" & iFile.Name & "]THA'!"
                With Sheets("TongHop")
                    .[A1] = "=IFERROR(LOOKUP(2,1/(" & FullPath & "A1:A10000<>""""),ROW(1:10000)),0)"
                    lr = .[A1]
                    If lr > 3 Then
                        .Range("A" & i).Resize(lr - 3, 13).FormulaArray = "=if(" & FullPath & _
                        "A4:M" & lr & "="""",""""," & FullPath & "A4:M" & lr & ")"
                        .Range("A" & i).Resize(lr - 3, 13).Value = .Range("A" & i).Resize(lr - 3, 13).Value
                        i = i + lr - 3
                    End If
                End With
            End If
        End If
    Next
    Sheets("TongHop").[A1].ClearContents
End With
End Sub

    HÌNH NHƯ THIẾU BIẾN lr MÁY TÔI CHẠY BỊ LỖI NHÉ+-+-+-+

    Anh thử xóa cái này đi xem hay dim lr

    Option Explicit
    Cách này hay thật … xài hàm tại nó sẻ khắc phục được số dòng rỗng khi lấy dữ liệu sẻ cho tốc độ nhanh
    Tùy biến vùng gán dữ liệu ngay tren Sheet không phát sinh lỗi
    Cảm ơn Bạn Mạnh hoc thêm 1 cái hay

    Ủa. Tôi thấy yêu cầu là lấy dữ liệu vùng A14:M100 chứ có nói gì đến dòng trống đâu nhỉ?

    Còn đây là cách của Mình …. mình sẻ cải tiến theo của hpkhuong nữa thì sẻ cho tốc độ nhanh hơn khi vùng dữ liệu cho trước dư thừa quá nhiều so với thực tế….

    Private Sub GetDataFile(strPath As String, SheetName As String, _
                         DataRange As String, Col As Long, Target As Range)

Static Fso As Object, ObjFile As Object
    Dim Arr(), sFile(), Res(), x As Long, k As Long, s  As Long
    Dim FilePath As String, Sht As String, i As Long, j As Long
    If Excel4MacroSheets.Count = 0 Then
        Application.Excel4MacroSheets.Add.Name = "Temp"
        Sheets("Temp").Visible = 2
    End If
    If Fso Is Nothing Then Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each ObjFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(ObjFile) Like "xls*" Then
            If Left(ObjFile.Name, 2) <> "~$" Then
                If ObjFile.Name <> ThisWorkbook.Name Then
                    x = x + 1
                    ReDim Preserve sFile(1 To x)
                    sFile(x) = ObjFile
                    For s = 1 To UBound(sFile)
                        Sht = SheetName & "'!" & DataRange
                        FilePath = "='" & Fso.GetParentFolderName(sFile(s)) _
                                 & "[" & Fso.GetFileName(sFile(s)) & "]" & Sht
                    Next
                    With Sheets("Temp").Range(DataRange)
                         .FormulaArray = FilePath
                         .Value = .Value
                         Res = .Value
                        .ClearContents
                    End With
                    ReDim Preserve Arr(1 To UBound(Res, 1), 1 To UBound(Res, 2))
                    For i = 1 To UBound(Res, 1)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                Arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                    If k Then Target.Resize(k, UBound(Res, 2)).Value = Arr
                End If
            End If
        End If
    Next
    Set Fso = Nothing
End Sub

Public Sub Main()
    Dim Path As String, Sht As String, Data As String
    Path = ThisWorkbook.Path                    ''duong dan tong hop File
    Sht = "THA"                                 ''Ten Sheet can Tong Hop
    Data = ("A4:M100")                          ''Vung du lieu can lay
    ActiveSheet.UsedRange.ClearContents
    GetDataFile Path, Sht, Data, 2, [A5]        ''2 = Cot Loc theo dieu kien co du lieu
End Sub

    Cái mảng sFile để làm gì nhỉ?

    Cảm ơn bạn viết vậy hơi thừa …từ từ ta điều chỉnh lại
    Cắt bớt như sau

    Private Sub GetDataFile(strPath As String, SheetName As String, _
                         DataRange As String, Col As Long, Target As Range)

Static Fso As Object, ObjFile As Object
    Dim Arr(), Res(), i As Long, j As Long, k As Long
    Dim FilePath As String, Sht As String
    If Excel4MacroSheets.Count = 0 Then
        Application.Excel4MacroSheets.Add.Name = "Temp"
        Sheets("Temp").Visible = 2
    End If
    If Fso Is Nothing Then Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each ObjFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(ObjFile) Like "xls*" Then
            If Left(ObjFile.Name, 2) <> "~$" Then
                If ObjFile.Name <> ThisWorkbook.Name Then
                    Sht = SheetName & "'!" & DataRange
                    FilePath = "='" & Fso.GetParentFolderName(ObjFile) _
                             & "[" & Fso.GetFileName(ObjFile) & "]" & Sht
                    With Sheets("Temp").Range(DataRange)
                         .FormulaArray = FilePath
                         .Value = .Value
                         Res = .Value
                        .ClearContents
                    End With
                    ReDim Preserve Arr(1 To UBound(Res, 1), 1 To UBound(Res, 2))
                    For i = 1 To UBound(Res, 1)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                Arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                    If k Then Target.Resize(k, UBound(Res, 2)).Value = Arr
                End If
            End If
        End If
    Next
    Set Fso = Nothing
End Sub

    Chắc cần sửa nữa –=0
    Dòng FilePath nên đưa lên trước vòng lặp. Dòng gán kết quả nên đưa ra sau vòng lặp.

    Thấy cũng na ná với giải pháp từng có trên GPE:
    [URL='https://www.giaiphapexcel.com/forum/showthread.php?39312-D%C3%B9ng-Macro-4-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-1-file-%C4%91ang-%C4%91%C3%B3ng']https://www.giaiphapexcel.com/forum/showthread.php?39312-Dùng-Macro-4-để-lấy-dữ-liệu-từ-1-file-đang-đóng
    Đúng không ta?

    hàm đó của Anh em biết lâu rồi mà….Anh xài ExecuteExcel4Macro

    [COLOR=#007700]Function [/COLOR][COLOR=#0000BB]GetData[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]sSheet [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]sAddr [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700])
  [/COLOR][COLOR=#0000BB]Dim pLink [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]iR [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Long[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]iC [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Long[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]Arr
  [/COLOR][COLOR=#007700]If [/COLOR][COLOR=#0000BB]Len[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700])) [/COLOR][COLOR=#0000BB]Then
    Arr [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]Range[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sAddr[/COLOR][COLOR=#007700])
    [/COLOR][COLOR=#0000BB]pLink [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"'" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Replace[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700]), [/COLOR][COLOR=#DD0000]"[" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700]) & [/COLOR][COLOR=#DD0000]"]"[/COLOR][COLOR=#007700]) & [/COLOR][COLOR=#0000BB]sSheet [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#DD0000]"'!"
    [/COLOR][COLOR=#007700]For [/COLOR][COLOR=#0000BB]iR [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]1 To Range[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sAddr[/COLOR][COLOR=#007700]).[/COLOR][COLOR=#0000BB]Rows[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Count
      [/COLOR][COLOR=#007700]For [/COLOR][COLOR=#0000BB]iC [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]1 To Range[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sAddr[/COLOR][COLOR=#007700]).[/COLOR][COLOR=#0000BB]Columns[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Count
        Arr[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]iR[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]iC[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#0000BB]ExecuteExcel4Macro[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]pLink [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Range[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sAddr[/COLOR][COLOR=#007700]).[/COLOR][COLOR=#0000BB]Cells[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]iR[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]iC[/COLOR][COLOR=#007700]).[/COLOR][COLOR=#0000BB]Address[/COLOR][COLOR=#007700](, , [/COLOR][COLOR=#0000BB]2[/COLOR][COLOR=#007700]))
      [/COLOR][COLOR=#0000BB]Next iC
    Next iR
    GetData [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]Arr
  End [/COLOR][COLOR=#007700]If[/COLOR]
[COLOR=#0000BB]End [/COLOR][COLOR=#007700]Function  [/COLOR]

    còn đây là Hàm Em mới viết lại

    Private Sub GetDataFile(strPath As String, SheetName As String, _
                        DataRange As String, Col As Long, Target As Range)

Static Fso As Object, ObjFile As Object
    Dim Arr(), Res(), i As Long, j As Long, k As Long
    Dim FilePath As String, Sht As String
    If Excel4MacroSheets.Count = 0 Then
        Application.Excel4MacroSheets.Add.Name = "Temp"
        Sheets("Temp").Visible = 2
    End If
    If Fso Is Nothing Then Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each ObjFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(ObjFile) Like "xls*" Then
            If Left(ObjFile.Name, 2) <> "~$" Then
                If ObjFile.Name <> ThisWorkbook.Name Then
                    Sht = SheetName & "'!" & DataRange
                    FilePath = "='" & Fso.GetParentFolderName(ObjFile) _
                             & "[" & Fso.GetFileName(ObjFile) & "]" & Sht
                    With Sheets("Temp").Range(DataRange)
                         .FormulaArray = FilePath
                         .Value = .Value
                         Res = .Value
                        .ClearContents
                    End With
                    ReDim Preserve Arr(1 To UBound(Res, 1), 1 To UBound(Res, 2))
                    For i = 1 To UBound(Res, 1)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                Arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                End If
            End If
        End If
    Next
    If k Then Target.Resize(k, UBound(Res, 2)).Value = Arr
    Set Fso = Nothing
End Sub

    Xem từ bài 13 trở đi…

    Thì bài 13 link sau Anh Viết như sau:

    [URL='https://www.giaiphapexcel.com/forum/showthread.php?39312-D%C3%B9ng-Macro-4-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-1-file-%C4%91ang-%C4%91%C3%B3ng/page2']https://www.giaiphapexcel.com/forum/showthread.php?39312-Dùng-Macro-4-để-lấy-dữ-liệu-từ-1-file-đang-đóng/page2

    [COLOR=#0000BB]Sub GetData[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]sSheet [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]sAddr [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]Target [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Range[/COLOR][COLOR=#007700])
  [/COLOR][COLOR=#0000BB]Dim pLink [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String
  [/COLOR][COLOR=#007700]If [/COLOR][COLOR=#0000BB]Len[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700])) [/COLOR][COLOR=#0000BB]Then
    pLink [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"'" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Replace[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700]), [/COLOR][COLOR=#DD0000]"[" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700]) & [/COLOR][COLOR=#DD0000]"]"[/COLOR][COLOR=#007700]) & [/COLOR][COLOR=#0000BB]sSheet [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#DD0000]"'!"
    [/COLOR][COLOR=#0000BB]With Range[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sAddr[/COLOR][COLOR=#007700])
      [/COLOR][COLOR=#0000BB]With Target[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Resize[/COLOR][COLOR=#007700](.[/COLOR][COLOR=#0000BB]Rows[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Count[/COLOR][COLOR=#007700], .[/COLOR][COLOR=#0000BB]Columns[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Count[/COLOR][COLOR=#007700])
        .[/COLOR][COLOR=#0000BB]FormulaArray [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"=" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]pLink [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]sAddr
        [/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Value [/COLOR][COLOR=#007700]= .[/COLOR][COLOR=#0000BB]Value
      End With
    End With
  End [/COLOR][COLOR=#007700]If[/COLOR]
[COLOR=#0000BB]End Sub  [/COLOR]

    Còn code đó Em học như đã nói ở bài 1 của [URL='https://www.giaiphapexcel.com/forum/member.php?189279-doveandrose'%5Ddoveandrose

    Hi… Hi… vậy chắc mình nhìn nhầm rồi, code bạn và mình chẳng có giống nhau đâu.

    Em mới coi lại code sau của Anh thì thấy như sau:

    [COLOR=#0000BB]Sub GetData[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]sSheet [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]sAddr [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]Target [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Range[/COLOR][COLOR=#007700])
  [/COLOR][COLOR=#0000BB]Dim pLink [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String
  [/COLOR][COLOR=#007700]If [/COLOR][COLOR=#0000BB]Len[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700])) [/COLOR][COLOR=#0000BB]Then
    pLink [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"'" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Replace[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700]), [/COLOR][COLOR=#DD0000]"[" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]Dir[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sFile[/COLOR][COLOR=#007700]) & [/COLOR][COLOR=#DD0000]"]"[/COLOR][COLOR=#007700]) & [/COLOR][COLOR=#0000BB]sSheet [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#DD0000]"'!"
    [/COLOR][COLOR=#0000BB]With Range[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]sAddr[/COLOR][COLOR=#007700])
      [/COLOR][COLOR=#0000BB]With Target[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Resize[/COLOR][COLOR=#007700](.[/COLOR][COLOR=#0000BB]Rows[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Count[/COLOR][COLOR=#007700], .[/COLOR][COLOR=#0000BB]Columns[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Count[/COLOR][COLOR=#007700])
        .[/COLOR][COLOR=#0000BB]FormulaArray [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"=" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]pLink [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000BB]sAddr
        [/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000BB]Value [/COLOR][COLOR=#007700]= .[/COLOR][COLOR=#0000BB]Value
      End With
    End With
  End [/COLOR][COLOR=#007700]If[/COLOR]
[COLOR=#0000BB]End Sub [/COLOR]

    Giống Anh về cách sử dụng FormulaArray ….

    1/đề lấy dữ liệu Anh sử dụng Replace để xử lý đường dẫn của File sẻ Tèo với Folder là tiếng việt có dấu …

    2/ Khi cho Vùng dữ liệu cần lấy Nhiều hơn so với thực tế có thì nó lấy lên phần dữ liệu cần lấy và phần O tròn như quả trứng gà ko Thôi …

    3/ Code Anh viết chỉ áp dụng cho lấy dữ liệu một File

    4/ quả thực ý tưởng FormulaArray Là Giống code Anh viết ….Nhưng khác nhau là:

    – Code Em viết lấy N +1 File Excel trong Folder mà không xác đinh tên file + số lượng

    – Em sử dụng Fso để xử lý thay vì Replace thì lấy được trong Folder là tiếng Việt có dấu ….

    – Em thêm điều Kiện lọc (Col) gán vào Mãng xử lý được O tròn như quả trứng gà …

    – Quả thực Em học từ Ý tưởng từ code bài 4 link sau:

    [URL='https://www.giaiphapexcel.com/forum/showthread.php?108604-H%E1%BB%8Fi-C%C3%A1ch-link-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%B1-%C4%91%E1%BB%99ng-t%E1%BB%AB-nhi%E1%BB%81u-file-v%C3%A0o-1-file']https://www.giaiphapexcel.com/forum/showthread.php?108604-Hỏi-Cách-link-dữ-liệu-tự-động-từ-nhiều-file-vào-1-file

    Như vậy bài #20 Anh Nói là có phần đúng….

    Em cảm ơn Anh rất nhiều nhờ Bài 20 của Anh mà Em nghiền ngẫm tới lui code của Anh và học thêm nhiều điều hay ….Mai mốt gặp lại Em mời vài chai nha …–=0

    Vậy Manh đưa code final của mạnh lên đây kèm file đính kèm để cho mình thử ngâm cứu với nhé. Hôm nay đang thử chạy trên Win10 &office 2016 x64 xem sao–=0
    Thông thường dạng dữ liệu này tôi hay dùng ADO để lấy.
    Nếu lấy 1 sheet của file đang đóng tôi sẽ dung ADO của anh Tuấn viết.
    Nếu lấy nhiều sheet của file đang đóng tôi sẽ dùng ADO của anh Chim Hồng viết.
    Nếu code của mạnh mà không vẫn đề khi chạy trên win và office nới trên thì chúng ta lại có thêm 1 giải pháp tuyệt vời nữa.

    Thì có trên đây rồi mà …Anh tài File bài 1 về Test Nha

    Public Sub GetDataFiles(strPath As String, SheetName As String, _
                        DataRange As String, Col As Long, Target As Range)

Static Fso As Object, ObjFile As Object
    Dim Arr(), Res(), i As Long, j As Long, k As Long
    Dim FilePath As String, Sht As String
    If Excel4MacroSheets.Count = 0 Then
        Application.Excel4MacroSheets.Add.Name = "Temp"
        Sheets("Temp").Visible = 2
    End If
    If Fso Is Nothing Then Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each ObjFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(ObjFile) Like "xls*" Then
            If Left(ObjFile.Name, 2) <> "~$" Then
                If ObjFile.Name <> ThisWorkbook.Name Then
                    Sht = SheetName & "'!" & DataRange
                    FilePath = "='" & Fso.GetParentFolderName(ObjFile) _
                             & "[" & Fso.GetFileName(ObjFile) & "]" & Sht
                    With Sheets("Temp").Range(DataRange)
                         .FormulaArray = FilePath
                         .Value = .Value
                         Res = .Value
                        .ClearContents
                    End With
                    ReDim Preserve Arr(1 To UBound(Res, 1), 1 To UBound(Res, 2))
                    For i = 1 To UBound(Res, 1)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                Arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                End If
            End If
        End If
    Next
    If k Then Target.Resize(k, UBound(Res, 2)).Value = Arr
    Set Fso = Nothing
End Sub

Public Sub Main()
    Dim Path As String, Sht As String, Data As String
    Path = ThisWorkbook.Path                    ''duong dan tong hop File
    Sht = "THA"                                 ''Ten Sheet can Tong Hop
    Data = ("A4:M100")                          ''Vung du lieu can lay
    ActiveSheet.UsedRange.ClearContents
    GetDataFiles Path, Sht, Data, 2, [A5]        ''2 = Cot Loc theo dieu kien co du lieu
End Sub

    Còn lấy 1 File Em viết trên GPE rồi … Anh tham khảo Thêm
    Nếu Thích ADO Tộng Hợp File duyệt đệ quy nữa thì Từ từ Em Úp

    [URL='https://www.giaiphapexcel.com/forum/showthread.php?113074-C%C3%A1ch-L%E1%BA%A5y-D%E1%BB%AF-Li%E1%BB%87u-File-%C4%90%C3%B3ng-M%C3%A0-Kh%C3%B4ng-S%E1%BB%AD-D%E1%BB%A5ng-ADO-Macro4-V%C3%A0-Workbook-Open/page2']https://www.giaiphapexcel.com/forum/showthread.php?113074-Cách-Lấy-Dữ-Liệu-File-Đóng-Mà-Không-Sử-Dụng-ADO-Macro4-Và-Workbook-Open/page2

    code của mạnh rất lạ là sau khi chạy code 1 lần. tôi xóa luôn sheet temp và bỏ đoạn code
    này nó vẫn ra kết quả
    'If Excel4MacroSheets.Count = 0 Then
    ' Application.Excel4MacroSheets.Add.Name = "Temp"
    ' Sheets("Temp").Visible = 2
    ' End If
    không hiểu luôn+-+-+-+

    Làm gì có nhỉ.

    Giống Anh về cách sử dụng FormulaArray ….

    Tôi nghĩ chỉ cần như vậy thì gọi là giống được rồi. Phần còn lại chỉ là hoa lá cành mà thôi.

    Nói có sách mách có chứng
    huuthang_bd có thể kiểm chứng ở file đính kèm.
    tôi đã chép folder này sang 1 máy khác và vẫn chạy bình thường–=0

    Bằng chứng này không đáng tin rồi –=0
    8PJ9DVUnono

    ủa sao mình không thấy được sheet temp như của hữu thắng ta ?. để tối tôi mở bằng office 2010 ở máy nhad xem sao.

    Sheet đó ở trạng thái siêu ẩn. Phải unhide bằng code mới được.

    huuthang có code show sheet khác không . tôi dùng code này thì show được các sheet nhưng cái sheet ms macro4 kia không ăn thua

    Sub UnhideSheet()
    Dim Ws As Worksheet
    For Each Ws In ActiveWorkbook.Worksheets
        Ws.Visible = True
    Next
End Sub

    +-+-+-+
    kha kha
    đã tìm thấy em ấy rồi
    sửa lại code của mạnh là nó lòi mặt ra rất dễ thương
    If Excel4MacroSheets.Count >= 1 Then

    Sheets("Temp").Visible = -1
    End If

    Phải vầy mới được.
    Sub UnhideAllSheet()
    Dim Sh As Object
    For Each Sh In ActiveWorkbook.Sheets
    Sh.Visible = xlSheetVisible
    Next
    End Sub
    Sheet Macro4 không phải là WorkSheet nên code của bạn không duyệt qua nó.

    Chỉ Cần vậy Thôi….Bạn

    Sub Unhide()
Sheets("Temp").Visible = 1
End Sub

    Cái mạnh đang nói là sheet temp trong file gốc của mạnh
    Cái đó tôi xóa mất tiêu rồi.chỉ còn mỗi sheet temp bằng MS_ macro4 thôi.
    Vơi lại code của mạnh chỉ có giá trị trong file đó thôi.nếu muốn show tất cả các macro sheet thì không được.
    Hôm nay rãnh lại khám phá thêm được vài chiêu.kha kha.
    cám ơn tất cả anh em . hẹn gặp lại ở SN lần 10 . ta cụng ly cho sướng nhá

    Reply
  2. hands says:
    19/01/2023 at 1:44 pm

    Chủ đề này không còn cách nào khác nửa sao bác Kieumanh, mấy ngày nay hóng xem tiếp nhưng dài cả cổ chẳng thấy bác xuất chiêu.

    Mình cũng đang chờ cái vụ lấy dữ liệu ở file có pass đây.Tuy nhiên code của Kieumanhchạy cũng ổn đấy chứ.

    Anh thử xài hàm sau Em viết sử dụng chung nhất muôn lấy dữ liệu lên cũng ok hay gán nó vào cái mảng cũng

    được , lấy dữ liệu bất cứ 1 File nào nếu đúng tên sheet thì nó lấy nếu sai thì nó cho 1 list cho mà chọn là ok…

    Còn nếu có pass Open nữa thì nó hiện lên cho mà nhập pass….

    Còn nếu muốn pass nữa thì thêm 2 dòng code là xong…–=0

    Nếu cho vùng dữ liệu 65536 thì nó lấy tốc độ châm hơn ADO nhanh hơn Workbooks.Open…
    Còn nếu cho nó dò tìm dòng cuối và gán vào thì tốc độ nhanh hơn như vậy Vùng lấy VD: [A10:M] …là xong …Em mới học của hpkhuong bài 7 đó cái vụ …đó …–=0+-+-+-+

    Public Sub GetDataFile(strPath As String, SheetName As String, DataRange As String, Res())
    Dim Fso As Object, FilePath As String, Sht As String
    If Excel4MacroSheets.Count = 0 Then
        Application.Excel4MacroSheets.Add.Name = "Temp"
        Sheets("Temp").Visible = 2
    End If
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Sht = SheetName & "'!" & DataRange
    FilePath = "='" & Fso.GetParentFolderName(strPath) _
             & "[" & Fso.GetFilename(strPath) & "]" & Sht
    With Sheets("Temp").Range(DataRange)
         .FormulaArray = FilePath
         .Value = .Value
         .Replace 0, "", 1, , , 0
         Res = .Value
        .ClearContents
    End With
    Set Fso = Nothing
End Sub
''
Public Sub Main()
    Dim Arr(), Path As String, Sht As String, Data As String
    Path = ThisWorkbook.Path & "Pass=1.xlsx"   ''Ten File can Lay
    ''Path = Application.GetOpenFilename("Excel Files,*.xl*")
    Sht = "THA"                                 ''Ten Sheet can lay
    Data = ("A6:J100")                          ''Vung du lieu can lay
    GetDataFile Path, Sht, Data, Arr()
    ActiveSheet.UsedRange.ClearContents
    Range("A6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End Sub

    Nhân tiện cái vụ này Em Tặng Anh Luôn cho nó đủ bộ …. Tổng Hợp N+1 File theo thuất toán Đệ Quy
    Em cũng hông cất sử dụng một mình mằn cái chi cả …
    Có điều muốn câu các thành viên tham gia thêm để Em tổng hợp nghiên cứu và đưa ra giải pháp tối Ưu nhất thôi mà …+-+-+-+–=0//**/

    Dim k As Long, Arr(1 To 65536, 1 To 13)
Public Sub GetDataFiles(strPath As String, SheetName As String, DataRange As String, Col As Long, Target As Range, InSub As Boolean)
Application.ScreenUpdating = False
    Dim Fso As Object, objFile As Object, SubFolder As Object
    Dim FullPath As String, Data As String, DataArray As String
    Dim Cels As String: Cels = Left(DataRange, 1)
    Dim Res(), i As Long, j As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each objFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(objFile) Like "xls*" Then
            If Left(objFile.Name, 2) <> "~$" Then
                If objFile.Name <> ThisWorkbook.Name Then
                    FullPath = "'" & strPath & "[" & objFile.Name & "]" & SheetName & "'!"
                    Rows(1).End(2) = "=IFERROR(LOOKUP(2,1/(" & FullPath & Cels & "1:" & Cels & "65536<>""""),ROW(1:65536)),0)"
                    Data = DataRange & Rows(1).End(2)
                    DataArray = "=" & FullPath & Data
                    With Target.Range(Data)
                        .FormulaArray = DataArray
                        .Value = .Value
                        Res = .Value
                        .ClearContents
                    End With
                    For i = 1 To UBound(Res, 1)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                Arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                End If
            End If
        End If
    Next
    If InSub Then
        For Each SubFolder In Fso.GetFolder(strPath).subFolders
            GetDataFiles SubFolder.Path, SheetName, DataRange, Col, Target, True
        Next SubFolder
    End If
    Rows(1).End(2) = Empty
    Set Fso = Nothing
Application.ScreenUpdating = True
End Sub

Public Sub Main()
    Dim Path As String, Sht As String, Data As String
    k = 0                                     
    Path = ThisWorkbook.Path                    ''duong dan tong hop File
    Sht = "THA"                                 ''Ten Sheet can Tong Hop
    Data = ("A4:M")                             ''Vung du lieu can lay
    ActiveSheet.UsedRange.ClearContents
    GetDataFiles Path, Sht, Data, 2, [A5], True ''2 = Cot Loc theo dieu kien co du lieu
    Range("A5").Resize(k, 13) = Arr
End Sub

    Cảm Ơn hpkhuong cái vụ … Mạnh áp dụng cho code này

    Còn nếu muốn pass nữa thì thêm 2 dòng code là xong…–=0

    xin được hỏi câu này nghĩa là gì ?!$@!!!$@!!!$@!!

    2 dòng truyền Pass Open

    Anh thử xài hàm sau Em viết sử dụng chung nhất muôn lấy dữ liệu lên cũng ok hay gán nó vào cái mảng cũng

    được , lấy dữ liệu bất cứ 1 File nào nếu đúng tên sheet thì nó lấy nếu sai thì nó cho 1 list cho mà chọn là ok…

    Còn nếu có pass Open nữa thì nó hiện lên cho mà nhập pass….

    Còn nếu muốn pass nữa thì thêm 2 dòng code là xong…–=0

    Nếu cho vùng dữ liệu 65536 thì nó lấy tốc độ châm hơn ADO nhanh hơn Workbooks.Open…
    Còn nếu cho nó dò tìm dòng cuối và gán vào thì tốc độ nhanh hơn như vậy Vùng lấy VD: [A10:M] …là xong …Em mới học của hpkhuong bài 7 đó cái vụ …đó …–=0+-+-+-+

    Public Sub GetDataFile(strPath As String, SheetName As String, DataRange As String, Res())
    Dim Fso As Object, FilePath As String, Sht As String
    If Excel4MacroSheets.Count = 0 Then
        Application.Excel4MacroSheets.Add.Name = "Temp"
        Sheets("Temp").Visible = 2
    End If
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Sht = SheetName & "'!" & DataRange
    FilePath = "='" & Fso.GetParentFolderName(strPath) _
             & "[" & Fso.GetFilename(strPath) & "]" & Sht
    With Sheets("Temp").Range(DataRange)
         .FormulaArray = FilePath
         .Value = .Value
         .Replace 0, "", 1, , , 0
         Res = .Value
        .ClearContents
    End With
    Set Fso = Nothing
End Sub
''
Public Sub Main()
    Dim Arr(), Path As String, Sht As String, Data As String
    Path = ThisWorkbook.Path & "Pass=1.xlsx"   ''Ten File can Lay
    ''Path = Application.GetOpenFilename("Excel Files,*.xl*")
    Sht = "THA"                                 ''Ten Sheet can lay
    Data = ("A6:J100")                          ''Vung du lieu can lay
    GetDataFile Path, Sht, Data, Arr()
    ActiveSheet.UsedRange.ClearContents
    Range("A6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End Sub

    Đừng có mà hiểu nhầm là code sẽ tự lấy dòng cuối cùng có dữ liệu. Mình đã thử và phát hiện điều này. Kết quả là tràn bộ nhớ khi lấy dữ liệu kiểu này. Mọi người có thời gian thử thêm xem sao nha.

    Anh thử bài 43 xem …tổng số dòng + lại ko quá 1 sheet khi gán kết quả và Msgbox Data xem nó lấy mỗi File

    Sao mình chạy bị báo lỗi ngay chổ màu đỏ vậy bạn.

    Dim k As Long, Arr(1 To 65536, 1 To 13)
Public Sub GetDataFiles(strPath As String, SheetName As String, DataRange As String, Col As Long, Target As Range, InSub As Boolean)
Application.ScreenUpdating = False
    Dim Fso As Object, objFile As Object, SubFolder As Object
    Dim FullPath As String, Data As String, DataArray As String
    Dim Cels As String: Cels = Left(DataRange, 1)
    Dim Res(), i As Long, j As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each objFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(objFile) Like "xls*" Then
            If Left(objFile.Name, 2) <> "~$" Then
                If objFile.Name <> ThisWorkbook.Name Then
                    FullPath = "'" & strPath & "[" & objFile.Name & "]" & SheetName & "'!"
                    Rows(1).End(2) = "=IFERROR(LOOKUP(2,1/(" & FullPath & Cels & "1:" & Cels & "65536<>""""),ROW(1:65536)),0)"
                    Data = DataRange & Rows(1).End(2)
                    DataArray = "=" & FullPath & Data
                    [COLOR=#ff0000][B]With Target.Range(Data)[/B][/COLOR]
                        .FormulaArray = DataArray
                        .Value = .Value
                        Res = .Value
                        .ClearContents
                    End With
                    For i = 1 To UBound(Res, 1)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                Arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                End If
            End If
        End If
    Next
    If InSub Then
        For Each SubFolder In Fso.GetFolder(strPath).subFolders
            GetDataFiles SubFolder.Path, SheetName, DataRange, Col, Target, True
        Next SubFolder
    End If
    Rows(1).End(2) = Empty
    Set Fso = Nothing
Application.ScreenUpdating = True
End Sub

Public Sub Main()
    Dim Path As String, Sht As String, Data As String
    k = 0                                    
    Path = ThisWorkbook.Path                    ''duong dan tong hop File
    Sht = "THA"                                 ''Ten Sheet can Tong Hop
    Data = ("A4:M")                             ''Vung du lieu can lay
    ActiveSheet.UsedRange.ClearContents
    GetDataFiles Path, Sht, Data, 2, [A5], True ''2 = Cot Loc theo dieu kien co du lieu
    Range("A5").Resize(k, 13) = Arr
End Sub

    Tôi thử không thấy lỗi. chắc máy bạn 64 bit

    Máy em chỉ 32 bit thôi bác ạ, ủa chạy lại lần nửa thì được rồi bác, không hiểu sao luôn.

    Bạn Thử cái mớ sau xem hay đó ..Mình tách ra nhiều Hàm cho Tiện sử dụng trong nhiều Trường Hợp mà tốc độ rất nhanh….
    Cảm ơn Anh Quanghai1969 về cách sử dụng Fso cho một mớ code sau và Hàm ListFileName

    Public Sub ListFileName(strPath As String, sArr())
    Dim objFile As Object, x As Long ''Lay tat ca cac File gan vao Mang
    With CreateObject("Scripting.FileSystemObject")
       For Each objFile In .GetFolder(strPath).Files
          If .GetExtensionName(objFile) Like "xls*" Then
             If Left(objFile.Name, 2) <> "~$" Then
                If objFile.Name <> ThisWorkbook.Name Then
                   x = x + 1
                   ReDim Preserve sArr(1 To x)
                   sArr(x) = objFile
                End If
             End If
          End If
       Next
    End With
End Sub

Private Sub GetDataArray(strPath As String, SheetName As String, DataRange As String, Target As Range, Res())
Application.ScreenUpdating = False
    Dim Fso As Object, FullPath As String, FilePath As String, Data As String
    Dim Cels As String: Cels = Left(DataRange, 1)
    Set Fso = CreateObject("Scripting.FileSystemObject")
    FullPath = "'" & Fso.GetParentFolderName(strPath) & "[" & Fso.GetFilename(strPath) & "]" & SheetName & "'!"
    Rows(1).End(2) = "=IFERROR(LOOKUP(2,1/(" & FullPath & Cels & "1:" & Cels & "65536<>""""),ROW(1:65536)),0)"
    Data = DataRange & Rows(1).End(2)
    FilePath = "=" & FullPath & Data
    With Target.Range(Data)
        .FormulaArray = FilePath
        .Value = .Value
        Res = .Value
       .ClearContents
    End With
    Rows(1).End(2) = Empty
    Set Fso = Nothing
Application.ScreenUpdating = True
End Sub

''==================
Private Sub GetFiles(strPath As String, SheetName As String, DataRange As String, Col As Long, Target As Range)
    Dim Arr(), sArr(), dArr(), Cols As Long ''Tong hop tat ca cac File trong Folder
    Dim i As Long, j As Long, k As Long, x As Long
    ListFileName strPath, sArr()
    For x = 1 To UBound(sArr)
        GetDataArray (sArr(x)), SheetName, DataRange, Target, Arr()
        Cols = UBound(Arr, 2)
        ReDim Preserve dArr(1 To 65536, 1 To Cols)
        For i = 1 To UBound(Arr, 1)
            If Arr(i, Col) <> Empty Then
                k = k + 1
                For j = 1 To UBound(Arr, 2)
                    dArr(k, j) = Arr(i, j)
                Next
            End If
        Next
    Next
    If k Then Target.Resize(k, UBound(Arr, 2)).Value = dArr
End Sub

Public Sub Main_GetFiles()
    Dim Path As String, Sht As String, Data As String
    Path = ThisWorkbook.Path
    Sht = "THA"                         ''Ten Sheet can lay
    Data = ("A4:M")                     ''Vung du lieu can lay
    ActiveSheet.UsedRange.ClearContents
    GetFiles Path, Sht, Data, 2, [A5]
End Sub

''==================
Public Sub Main()
    Dim Arr(), Path As String, Sht As String, Data As String
    Path = ThisWorkbook.Path & "Mau thong ke 1.xls"
    Sht = "THA"                                 ''Ten Sheet can lay
    Data = ("A4:M")                             ''Vung du lieu can lay
    ActiveSheet.UsedRange.ClearContents
    GetDataArray Path, Sht, Data, [A5], Arr()   ''[A5] la noi gan CT mang = Vung gan du lieu
    Range("A5").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End Sub

Public Sub Main_Arr()
    Dim Path As String, Sht As String, Data As String
    Dim dArr(), Arr(), i As Long, j As Long, k As Long
    Path = ThisWorkbook.Path & "Mau thong ke 1.xls"
    ''Path = Application.GetOpenFilename("Excel Files,*.xl*")
    Sht = "THA"             ''Ten Sheet can lay
    Data = ("A4:M")         ''Vung du lieu can lay
    GetDataArray Path, Sht, Data, [A5], Arr()
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr, 1)
        If Arr(i, 2) <> Empty Then
            k = k + 1
            For j = 1 To UBound(Arr, 2)
                dArr(k, j) = Arr(i, j)
            Next
        End If
    Next
    ActiveSheet.UsedRange.ClearContents
    If k Then Range("A5").Resize(k, UBound(Arr, 2)).Value = dArr
End Sub

Public Sub Main_Dic()
    Dim Path As String, Sht As String, Data As String
    Dim dArr(), Arr(), i As Long, j As Long, k As Long
    Path = ThisWorkbook.Path & "Mau thong ke 1.xls"
    ''Path = Application.GetOpenFilename("Excel Files,*.xl*")
    Sht = "THA"             ''Ten Sheet can lay
    Data = ("A4:M")         ''Vung du lieu can lay

GetDataArray Path, Sht, Data, [A5], Arr()
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(Arr)
            If Not .Exists(Arr(i, 1)) Then
                .Add Arr(i, 1), Arr(i, 2)
            End If
        Next
        ActiveSheet.UsedRange.ClearContents
        Range("A5").Resize(.Count) = Application.Transpose(.keys)
        Range("B5").Resize(.Count) = Application.Transpose(.items)
    End With
End Sub

    Bạn tải Files bài 1 Test nha

    Reply

Leave a Reply

Your email address will not be published. Required fields are marked *

Quảng cáo
▣ Excel Ứng Dụng

Cũ vẫn chất

So sánh 3 cách lấy dữ liệu từ 1 file đang đóng So sánh 3 cách lấy dữ liệu từ 1 file đang đóng Tra cứu : MST , CCCD (CMND), Tên DN theo danh sách MST Tra cứu : MST , CCCD (CMND), Tên DN theo danh sách MST Vấn đề HttpRequest “Get” trả về Response khác với Reponse thao tác trên trình duyệt Vấn đề HttpRequest “Get” trả về Response khác với Reponse thao tác trên trình duyệt [Bài tập vui]: Tìm ra mươi ngày 13 rơi vào thứ sáu gần hôm nay nhất! [Bài tập vui]: Tìm ra mươi ngày 13 rơi vào thứ sáu gần hôm nay nhất! Tổng hợp dữ liệu từ nhiều sheet Tổng hợp dữ liệu từ nhiều sheet Tính toán và đếm hàng hóa xuất nhập khẩu dùng Dictionary Tính toán và đếm hàng hóa xuất nhập khẩu dùng Dictionary

Xem thêm