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

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Kiều Mạnh

Kiều Mạnh

I don't program, I beat code into submission!!!
Tham gia
9/6/12
Bài viết
5,538
Được thích
4,133
Giới tính
Nam
Xuất phát từ ý tưởng ở 2 thớt sau:

http://www.giaiphapexcel.com/forum/...iệu-từ-nhiều-file-khác-nhau-vào-file-tổng-hợp

http://www.giaiphapexcel.com/forum/...-excel-đang-đóng-bằng-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 doveandrose
sau một thời gian mạnh Theo 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à [A14:M100]

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à [A14:M100]

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 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
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọ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.
PHP: 
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 & "\[" & iFile.Name & "]THA'!A14:M100"
                    .Value = .Value
                End With
                i = i + 1
            End If
        End If
    Next
End With
End Sub
 
Upvote 0
huuthang_bd đã viết:
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.
PHP: 
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 & "\[" & iFile.Name & "]THA'!A14:M100"
                    .Value = .Value
                End With
                i = i + 1
            End If
        End If
    Next
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Đây là link file. Hi
Bác làm luôn câu 2 đi ạ. Để em học hỏi ạ.
 
Upvote 0
huuthang_bd đã viết:
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.
PHP: 
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 & "\[" & iFile.Name & "]THA'!A14:M100"
                    .Value = .Value
                End With
                i = i + 1
            End If
        End If
    Next
End With
End Sub
Nhấp chuột vào đây để mở rộng...
sao mình chạy code nó không thấy nhúc nhíc là sao ta...
 
Upvote 0
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.
Mã: 
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
 
Upvote 0
hpkhuong đã viết:
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
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Cách này hay thật ... xài hàm tại [A1] 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
 
Upvote 0
kieu manh đã viết:
Cách này hay thật ... xài hàm tại [A1] 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
Nhấp chuột vào đây để mở rộng...

Ủ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ỉ?
 
Upvote 0
Còn đây là cách của Mình .... mình sẻ cải tiến theo [A1] 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ế....

Mã: 
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
 
Upvote 0
kieu manh đã viết:
Còn đây là cách của Mình .... mình sẻ cải tiến theo [A1] 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ế....

Mã: 
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
Nhấp chuột vào đây để mở rộng...
Cái mảng sFile để làm gì nhỉ?
 
Upvote 0
huuthang_bd đã viết:
Cái mảng sFile để làm gì nhỉ?
Nhấp chuột vào đây để mở rộng...
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
Mã: 
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
 
Upvote 0
hpkhuong đã viết:
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
Mã: 
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)"
                    [SIZE=3][COLOR=#ff0000]lr[/COLOR][/SIZE] = .[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
Nhấp chuột vào đây để mở rộng...
HÌNH NHƯ THIẾU BIẾN lr MÁY TÔI CHẠY BỊ LỖI NHÉ+-+-+-+
 
Upvote 0
kieu manh đã viết:
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
Mã: 
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
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
ndu96081631 đã viết:
Thấy cũng na ná với giải pháp từng có trên GPE:
http://www.giaiphapexcel.com/forum/...ng-Macro-4-để-lấy-dữ-liệu-từ-1-file-đang-đóng
Đúng không ta?
Nhấp chuột vào đây để mở rộng...
hàm đó của Anh em biết lâu rồi mà....Anh xài ExecuteExcel4Macro

Mã:
Mã: 
[COLOR=#007700][FONT=monospace]Function [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]GetData[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sSheet [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
  [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dim pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iR [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Long[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iC [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Long[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Arr
  [/FONT][/COLOR][COLOR=#007700][FONT=monospace]If [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Len[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace])) [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Then
    Arr [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
    [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"'" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Replace[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace]), [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"[" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) & [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"]"[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) & [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sSheet [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"'!"
    [/FONT][/COLOR][COLOR=#007700][FONT=monospace]For [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iR [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]1 To Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Rows[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Count
      [/FONT][/COLOR][COLOR=#007700][FONT=monospace]For [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iC [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]1 To Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Columns[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Count
        Arr[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iR[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iC[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) = [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]ExecuteExcel4Macro[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Cells[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iR[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]iC[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Address[/FONT][/COLOR][COLOR=#007700][FONT=monospace](, , [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]2[/FONT][/COLOR][COLOR=#007700][FONT=monospace]))
      [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Next iC
    Next iR
    GetData [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Arr
  End [/FONT][/COLOR][COLOR=#007700][FONT=monospace]If
[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]End [/FONT][/COLOR][COLOR=#007700][FONT=monospace]Function  [/FONT][/COLOR][SIZE=4][B][COLOR=#0000BB][FONT=monospace]
[/FONT][/COLOR][/B][/SIZE]
còn đây là Hàm Em mới viết lại
Mã: 
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
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Xem từ bài 13 trở đi...
Nhấp chuột vào đây để mở rộng...
Thì bài 13 link sau Anh Viết như sau:

http://www.giaiphapexcel.com/forum/...ro-4-để-lấy-dữ-liệu-từ-1-file-đang-đóng/page2

Mã: 
[COLOR=#0000BB][FONT=monospace]Sub GetData[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sSheet [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Target [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
  [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dim pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String
  [/FONT][/COLOR][COLOR=#007700][FONT=monospace]If [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Len[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace])) [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Then
    pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"'" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Replace[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace]), [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"[" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) & [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"]"[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) & [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sSheet [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"'!"
    [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]With Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
      [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]With Target[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Resize[/FONT][/COLOR][COLOR=#007700][FONT=monospace](.[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Rows[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Count[/FONT][/COLOR][COLOR=#007700][FONT=monospace], .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Columns[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Count[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
        .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]FormulaArray [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"=" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr
        [/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Value [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Value
      End With
    End With
  End [/FONT][/COLOR][COLOR=#007700][FONT=monospace]If
[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]End Sub  [/FONT][/COLOR]
Còn code đó Em học như đã nói ở bài 1 của doveandrose
 
Upvote 0
kieu manh đã viết:
Thì bài 13 link sau Anh Viết như sau:

http://www.giaiphapexcel.com/forum/...ro-4-để-lấy-dữ-liệu-từ-1-file-đang-đóng/page2

Mã: 
[COLOR=#0000BB][FONT=monospace]Sub GetData[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sSheet [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Target [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
  [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dim pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]As [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]String
  [/FONT][/COLOR][COLOR=#007700][FONT=monospace]If [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Len[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace])) [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Then
    pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"'" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Replace[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace], [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace]), [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"[" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Dir[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sFile[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) & [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"]"[/FONT][/COLOR][COLOR=#007700][FONT=monospace]) & [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sSheet [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"'!"
    [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]With Range[/FONT][/COLOR][COLOR=#007700][FONT=monospace]([/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
      [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]With Target[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Resize[/FONT][/COLOR][COLOR=#007700][FONT=monospace](.[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Rows[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Count[/FONT][/COLOR][COLOR=#007700][FONT=monospace], .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Columns[/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Count[/FONT][/COLOR][COLOR=#007700][FONT=monospace])
        .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]FormulaArray [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= [/FONT][/COLOR][COLOR=#DD0000][FONT=monospace]"=" [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]pLink [/FONT][/COLOR][COLOR=#007700][FONT=monospace]& [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]sAddr
        [/FONT][/COLOR][COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Value [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Value
      End With
    End With
  End [/FONT][/COLOR][COLOR=#007700][FONT=monospace]If
[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]End Sub  [/FONT][/COLOR]
Còn code đó Em học như đã nói ở bài 1 của doveandrose
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
Nếu các file lấy dữ liệu có password open file thì sao ta, vì đang viết bài trên điện thoại nên không thể test được.)*&^)
 
Upvote 0
Upvote 0
ndu96081631 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Em mới coi lại code sau của Anh thì thấy như sau:
Mã: 
[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:

http://www.giaiphapexcel.com/forum/...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
 
Upvote 0
kieu manh đã viết:
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
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
Lê Duy Thương đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Thì có trên đây rồi mà ...Anh tài File bài 1 về Test Nha
Mã: 
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

http://www.giaiphapexcel.com/forum/...ông-Sử-Dụng-ADO-Macro4-Và-Workbook-Open/page2
 
Upvote 0
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+-+-+-+
 
Upvote 0
Lê Duy Thương đã viết:
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+-+-+-+
Nhấp chuột vào đây để mở rộng...
Làm gì có nhỉ.
Giống Anh về cách sử dụng FormulaArray ....
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
huuthang_bd đã viết:
Làm gì có nhỉ.

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.
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

Upvote 0
Lê Duy Thương đã viết:
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
Nhấp chuột vào đây để mở rộng...
Bằng chứng này không đáng tin rồi --=0
[video=youtube;8PJ9DVUnono]https://www.youtube.com/watch?v=8PJ9DVUnono&feature=youtu.be[/video]
 
Upvote 0
huuthang_bd đã viết:
Bằng chứng này không đáng tin rồi --=0
[video=youtube;8PJ9DVUnono]https://www.youtube.com/watch?v=8PJ9DVUnono&feature=youtu.be[/video]
Nhấp chuột vào đây để mở rộng...
ủ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.
 
Upvote 0
huuthang_bd đã viết:
Sheet đó ở trạng thái siêu ẩn. Phải unhide bằng code mới được.
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
Upvote 0
Lê Duy Thương đã viết:
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
Nhấp chuột vào đây để mở rộng...
Phải vầy mới được.
PHP: 
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ó.
 
Upvote 0
huuthang_bd đã viết:
Phải vầy mới được.
PHP: 
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ó.
Nhấp chuột vào đây để mở rộng...
Chỉ Cần vậy Thôi....Bạn
Mã: 
Sub Unhide()
Sheets("Temp").Visible = 1
End Sub
 
Upvote 0
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á
 
Lần chỉnh sửa cuối:
Upvote 0
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.
 
Upvote 0
giaiphap đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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ứ.
 
Upvote 0
Lê Duy Thương đã viết:
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ứ.
Nhấp chuột vào đây để mở rộng...
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ụ [A1] ...đó ...--=0+-+-+-+
Mã: 
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
 
Upvote 0
Lê Duy Thương đã viết:
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ứ.
Nhấp chuột vào đây để mở rộng...
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//**/
Mã: 
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ụ [A1]... Mạnh áp dụng cho code này
 
Upvote 0
kieu manh đã viết:
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ụ [A1] ...đó ...--=0+-+-+-+
Nhấp chuột vào đây để mở rộng...

Đừng có mà hiểu nhầm [A10: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.
 
Upvote 0
quanghai1969 đã viết:
Đừng có mà hiểu nhầm [A10: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.
Nhấp chuột vào đây để mở rộng...
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 [A10:M Bao nhieu]
 
Lần chỉnh sửa cuối:
Upvote 0
kieu manh đã viết:
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//**/
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Sao mình chạy bị báo lỗi ngay chổ màu đỏ vậy bạn.
 
Upvote 0
giaiphap đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
Mã: 
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
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng (1 người xem)
Trả lời
16
Đọc
315
Phan Thế Hiệp
Phan Thế Hiệp
Y
Lấy dữ liệu từ sheet chi tiết sang sheet tổng hợp hàng dọc
Trả lời
5
Đọc
516
SA_DQ
SA_DQ
N
Hàm tính chuỗi số trong 1 ô hoặc 1 dãy ô ra tổng kết quả.
Trả lời
2
Đọc
90
minhminh27
minhminh27
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
382
Đọc
45K
TomRuoi
TomRuoi
NguyenthiH
Mở file Excel có Pass Open
Trả lời
39
Đọc
3K
Hoàng Tuấn 868
H
M
Tách dữ liệu trong 1 file thành nhiều sheet theo số lượng dòng
    • Ngạc nhiên
Trả lời
25
Đọc
3K
Hoàng Tuấn 868
H
T
Tìm số hóa đơn trong chuỗi (1 người xem)
Trả lời
11
Đọc
419
thao nguyen01
T
T
  • Question Question
Nhờ ACE cao thủ hỗ trợ mình có một chương trình EXCEL về phân công lớp cho giáo viên
Trả lời
6
Đọc
315
DeTong
D
T
Nhờ các anh chị sửa dùm công thức ạ.
Trả lời
10
Đọc
206
trantrungvinh1989
T
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
24
Đọc
2K
phuongdaik98
P
Phan Thế Hiệp
Quy đổi từ Thu nhập sau thuế (TNCN) ra Thu nhập tính thuế
    • Yêu thích
    • Thích
Trả lời
1
Đọc
337
Phan Thế Hiệp
Phan Thế Hiệp
V
Quên mật khẩu file excel
Trả lời
25
Đọc
2K
YêuCN
Y
Nguyen Rem
  • Question Question
Lỗi "User-defined type not defined" khi khai báo biến
Trả lời
28
Đọc
2K
nguyendang95
N
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
longlacda
L
V
Công thức để phân công chuyên môn cho giáo viên
Trả lời
5
Đọc
292
vietvanyen
V
G
AddIn convert ngày dương lịch sang âm lịch và ngược lại + đọc ngày tháng
Trả lời
20
Đọc
10K
du trung kien
D
8
Hàm trong excel
Trả lời
3
Đọc
117
Hoàng Tuấn 868
H
N
Chuyển giờ công từ bảng công vào bảng tính
Trả lời
16
Đọc
348
ngouyen1505
N
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
7
Đọc
703
nguyendang95
N
Nga1852k
lỗi excel không chèn được dòng và không xóa được dòng
Trả lời
2
Đọc
152
Nga1852k
Nga1852k
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom