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,129
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ê 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.
Web KT

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

P
  • Question Question
Lấy giá trị duy nhất nhiều cột khác nhau (1 người xem)
Trả lời
3
Đọc
88
phamgiang90
P
N
Công thức tính điền số lượng lũy kế giao hàng theo điều kiện (4 người xem)
Trả lời
0
Đọc
10
Ngocminh19
N
4
EXCEL TỰ ĐỘNG MỞ TRÊN WEB
Trả lời
7
Đọc
146
4545
4
HeSanbi
Office Tool Plus - Ứng dụng tải, cài đặt, gỡ bỏ, nhập khóa, xóa khóa bản quyền Office nhanh chóng (1 người xem)
    • Thích
Trả lời
1
Đọc
115
ptm0412
ptm0412
A
Xin các bác chỉ giúp cách thống kê danh sách học sinh (1 người xem)
Trả lời
6
Đọc
98
Anhnn9
A
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
7
Đọc
272
Việt Nguyễn 86
Việt Nguyễn 86
cadafi
Hướng dẫn tạo Macro chuyển số thành chữ trong Open Office 3.1 (Tiếng Việt Unicode)
Trả lời
11
Đọc
25K
minnad123
M
Nguyễn Duy Tuân
Lập trình VBA với Google Drive, OneDrive, DropBox cho Upload-Download-Copy-Move...
    • Cảm ơn
Trả lời
2
Đọc
158
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
hỏi về đếm số ngày doanh thu tăng và giảm
Trả lời
5
Đọc
72
VetMini
V
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
263
Đọc
28K
ongke0711
ongke0711
T
xin công thức tính được số người còn lại theo từng cột
Trả lời
1
Đọc
57
bebo021999
B
D
Hỏi về cách sử dụng data table
Trả lời
2
Đọc
76
ptm0412
ptm0412
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
8
Đọc
163
VetMini
V
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết (1 người xem)
2
Trả lời
21
Đọc
24K
Bát Giới
Bát Giới
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
10
Đọc
7K
VetMini
V
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
15
Đọc
302
ptm0412
ptm0412
dangvandang
Addin mở rộng cho xây dựng (1 người xem)
    • Thích
2
Trả lời
34
Đọc
3K
vlba
V
M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
4
Đọc
145
mtbackup
M
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
3
Đọc
189
hoangtuaotrang_hp_vn
H
A
ExTools : Hơn 60 tính năng bổ sung cho Excel
    • Thích
Trả lời
3
Đọc
9K
mangat060083
M
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom