Tổng hợp dữ liệu cùng cấu trúc trên cùng một sheet ở nhiều file vào file Tổng hợp (1 người xem)

[titanic20072007]

Chào các bạn.
Mình có một tình huống cần các bạn giúp đỡ, cụ thể thế này: Mình có nhiều tệp dữ liệu A, B, C, D,... (số lượng không biết trước) có số sheet và cấu trúc dữ liệu giống nhau ở trong cùng một thư mục. Mình cần phải copy và dán dữ liệu từ sheet Data của các tệp A, B, C, D,... vào tệp Tổng hợp. Copy và paste thủ công lâu quá, mình nhờ các bạn viết hộ code giúp làm việc trên. Cảm ơn các bạn. (tệp dữ liệu mẫu mình gửi kèm ở dưới).

 

[HieuCD]

bạn copy file vào chung với các file khác, bấm ngôi sao chạy code

 

[titanic20072007]

Cảm ơn bạn HieuCD mình chạy thử và thấy code chạy rất nhanh nhưng khi copy chỉ có tệp cuối cùng là không bị mất dòng cuối. Bạn xem và chỉnh lại code hộ mình nhé.

 

[Let'GâuGâu]

Chào các bạn.
Mình có một tình huống cần các bạn giúp đỡ, cụ thể thế này: Mình có nhiều tệp dữ liệu A, B, C, D,... (số lượng không biết trước) có số sheet và cấu trúc dữ liệu giống nhau ở trong cùng một thư mục. Mình cần phải copy và dán dữ liệu từ sheet Data của các tệp A, B, C, D,... vào tệp Tổng hợp. Copy và paste thủ công lâu quá, mình nhờ các bạn viết hộ code giúp làm việc trên. Cảm ơn các bạn. (tệp dữ liệu mẫu mình gửi kèm ở dưới).

góp vui
1- nhớ mở vba Alt F11==>Tools > References check vào 2 mục
"Microsoft Scripting Runtime"
"Microsoft ActiveX Data Objects 2.5 Library"

Option Explicit

Sub ListFiles()

'Tools > References in the Visual Basic Editor (Alt+F11)
    'Set a reference to
    '"Microsoft Scripting Runtime"
    '"Microsoft ActiveX Data Objects 2.5 Library"
    
    'Declare the variables
    Dim objFSO As FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect, SourceFile, SourceSheet, SourceRange As String
    Dim szSQL As String
    
    'clearcontent
    [A8:AC60000].ClearContents
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the folder
    Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        If objFile <> ThisWorkbook.Path & "\" & ThisWorkbook.Name Then
        
        SourceFile = objFile
        SourceSheet = "Data"
        SourceRange = "A8:AC60000"
    
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "]"
    
        Set rsCon = CreateObject("ADODB.Connection")
        Set rsData = CreateObject("ADODB.Recordset")
        rsCon.Open szConnect
        rsData.Open szSQL, rsCon, 0, 1, 1

        If Not rsData.EOF Then
                [a60000].End(3).Offset(1).CopyFromRecordset rsData
        End If

        rsData.Close
        Set rsData = Nothing
        rsCon.Close
        Set rsCon = Nothing
        End If
    Next objFile        
End Sub

 

[befaint]

bạn copy file vào chung với các file khác, bấm ngôi sao chạy code

1/ Nếu trong Folder có file excel mà không có Sheets("Data") thì sẽ lỗi

ir = WB.Sheets("Data").Range("B65000").End(xlUp).Row

2/ Nếu xóa dữ liệu ở dòng 8 và 9 đi rồi click vào "1 sao" thì file bung "banh xác".

 

[befaint]

Chào các bạn.
Mình có một tình huống cần các bạn giúp đỡ, cụ thể thế này: Mình có nhiều tệp dữ liệu A, B, C, D,... (số lượng không biết trước) có số sheet và cấu trúc dữ liệu giống nhau ở trong cùng một thư mục. Mình cần phải copy và dán dữ liệu từ sheet Data của các tệp A, B, C, D,... vào tệp Tổng hợp. Copy và paste thủ công lâu quá, mình nhờ các bạn viết hộ code giúp làm việc trên. Cảm ơn các bạn. (tệp dữ liệu mẫu mình gửi kèm ở dưới).

Chào titanic20072007,

Bạn thử file đính kèm nhé.
Mở file lên, click vào nút "Tổng hợp" của bạn rồi chọn Folder chứa các file cần tổng hợp, click OK.

 

[nmhung49]

góp vui
1- nhớ mở vba Alt F11==>Tools > References check vào 2 mục
"Microsoft Scripting Runtime"
"Microsoft ActiveX Data Objects 2.5 Library"

Dạo này dùng ADO không ta!!!, mà lỡ dùng CreateObject rồi còn đày đọ con người ta check thêm ADO nữa?

 

[Let'GâuGâu]

Dạo này dùng ADO không ta!!!, mà lỡ dùng CreateObject rồi còn đày đọ con người ta check thêm ADO nữa?

đang học nên còn háo hức.....cái gì mới cũng khoái.....hihihiih
===
nếu không stick nó báo lỗi user defined not ....gì đó anh ơi, học lóm nên cũng hong có rành lắm........hihihih

 

[doveandrose]

đang học nên còn háo hức.....cái gì mới cũng khoái.....hihihiih
===
nếu không stick nó báo lỗi user defined not ....gì đó anh ơi, học lóm nên cũng hong có rành lắm........hihihih

để "anh" chỉ cho
muốn hết lỗi thì sửa mấy cái ni

Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFile As File

thành

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object

sửa cho code hết báo lỗi thôi chứ còn chạy có đúng hay không là chuyện ... hên xui

 

[HieuCD]

Cảm ơn bạn HieuCD mình chạy thử và thấy code chạy rất nhanh nhưng khi copy chỉ có tệp cuối cùng là không bị mất dòng cuối. Bạn xem và chỉnh lại code hộ mình nhé.

Bạn dùng code mới, đã bẩy các lỗi

Sub GhepFile()
Dim WB As Workbook, MainWB As Workbook, FSO As Object, FileItem As Object, Arr, Farr
Dim ir As Long, irF As Long, FistR As Long
Application.ScreenUpdating = False
irF = Range("A65000").End(xlUp).Row
If irF > Range("B65000").End(xlUp).Row + 4 Then
    Range("A" & irF - 6 & ":AD" & irF).Copy Range("A65100")
End If
Range("A9:AD65000").Clear
FistR = 7
Set MainWB = ThisWorkbook
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each FileItem In FSO.GetFolder(ThisWorkbook.Path).Files
    If FileItem.Name <> MainWB.Name And Left(FileItem.Name, 1) <> "~" _
        And FileItem.Name <> "x.xlsx" And FileItem.Name Like "*.xls*" Then
        Set WB = Workbooks.Open(FileItem.Path)
        Err.Clear
        ir = WB.Sheets("Data").Range("B65000").End(xlUp).Row
        If Err.Number > 0 Then
            WB.Close False:   GoTo thoat
        End If
        If Not IsError(ir) Then
            Arr = WB.Sheets("Data").Range("A8:Ad" & ir)
            WB.Close False
            If ir >= 8 Then
                Range("A" & FistR + 1).Resize(UBound(Arr), 30) = Arr
                FistR = FistR + UBound(Arr)
            End If
        End If
    End If
thoat:
Next FileItem
irF = Range("B65000").End(xlUp).Row
Range("A8:AD8").Copy
Range("A8:AD" & irF).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Range("A65100:AD65106").Copy Range("A" & irF).Offset(2, 0)
Application.CutCopyMode = False
Range("A65100:AD65106").Clear
Set FileItem = Nothing
Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

 

[titanic20072007]

Cảm ơn các bạn và HieuCD đã nhiệt tình giúp đỡ. Mình đã chạy thử với dữ liệu thực tế thì code của HieuCD chạy khá chậm do phải mở từng tệp lên để copy. Mình nghe nói có cách nào đó lấy dữ liệu mà không cần mở tệp lên đúng không. các bạn hộ mình code như vậy được không? Cảm ơn các bạn.

 

[Let'GâuGâu]

Cảm ơn các bạn và HieuCD đã nhiệt tình giúp đỡ. Mình đã chạy thử với dữ liệu thực tế thì code của HieuCD chạy khá chậm do phải mở từng tệp lên để copy. Mình nghe nói có cách nào đó lấy dữ liệu mà không cần mở tệp lên đúng không. các bạn hộ mình code như vậy được không? Cảm ơn các bạn.

bùn ghê lun đó bạn....huhuhhuhu

 

[befaint]

Cảm ơn các bạn và HieuCD đã nhiệt tình giúp đỡ. Mình đã chạy thử với dữ liệu thực tế thì code của HieuCD chạy khá chậm do phải mở từng tệp lên để copy. Mình nghe nói có cách nào đó lấy dữ liệu mà không cần mở tệp lên đúng không. các bạn hộ mình code như vậy được không? Cảm ơn các bạn.

Là bài #4 đó bạn. ADO không thấy mở file nhưng vẫn có mở ngầm.

 

[doveandrose]

bùn ghê lun đó bạn....huhuhhuhu

làm sao con khóc ? có vấn đề gì nói ta nghe

 

[Let'GâuGâu]

làm sao con khóc ? có vấn đề gì nói ta nghe

"con" hong câu được "like" nên con khóc...huhuuhhuhu
ông tiên co cách nào câu like hong, chỉ con với......heheeh

 

[titanic20072007]

Mình đã thử code của Let'GâuGâu nhưng lỗi ở dòng Dim objFSO As FileSystemObject
Bạn có thể xem lại được không.

 

[HieuCD]

Mình đã thử code của Let'GâuGâu nhưng lỗi ở dòng Dim objFSO As FileSystemObject
Bạn có thể xem lại được không.

bạn xem bài #9 để khai báo lại, code bạn Let'GâuGâu chạy nhanh hơn code của mình

 

[Let'GâuGâu]

dùng hàm 4macro của sư tổ AN_DU

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

Sub ListFiles()
On Error GoTo thoat
    'Declare the variables
    Dim objFSO, objFolder, objFile As Object
    Dim myfile As String
    'clearcontent
    [A8:AC60000].ClearContents
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the folder
    Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        If objFile <> ThisWorkbook.Path & "\" & ThisWorkbook.Name Then
            myfile = objFile
            [a60000].End(3).Offset(1).Resize(iR - 1, 30).Value = GetData(myfile, "Data", "A8:AC70")
        End If
    Next objFile
thoat:
End Sub

nhưng hình như chạy chậm hơn ADO
có mấy chục dòng, sao mà nó cứ quay mồng mồng riết

 

[titanic20072007]

Cảm ơn Let'GâuGâu đã giúp đỡ. Mình sẽ chạy thử với dữ liệu thực xem có nhanh hơn không. Bạn có thể chỉnh lại code ADO ở #4 được không mình đã chỉnh theo bài #9 cũng chạy được báo lỗi hoài.

 

[Let'GâuGâu]

Cảm ơn Let'GâuGâu đã giúp đỡ. Mình sẽ chạy thử với dữ liệu thực xem có nhanh hơn không. Bạn có thể chỉnh lại code ADO ở #4 được không mình đã chỉnh theo bài #9 cũng chạy được báo lỗi hoài.

Theo bạn "Do" nói thì khái báo thành object thì khỏi phải cài là trong reference
tuy nhiên nếu vẫn bị lổi thì bạn thử làm cái này (trong bài #4 tôi cũng đã nói, không biết bạn có làm chưa)
===
nhớ mở vba Alt F11==>Tools > References check vào 2 mục
"Microsoft Scripting Runtime"
"Microsoft ActiveX Data Objects 2.5 Library"
===

Option Explicit

Sub ListFiles()

'Tools > References in the Visual Basic Editor (Alt+F11)
    'Set a reference to
    '"Microsoft Scripting Runtime"
    '"Microsoft ActiveX Data Objects 2.5 Library"
    
    'Declare the variables
    Dim objFSO, objFolder, objFile As Object
    
    
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect, SourceFile, SourceSheet, SourceRange As String
    Dim szSQL As String
    
    'clearcontent
    [A8:AC60000].ClearContents
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the folder
    Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        If objFile <> ThisWorkbook.Path & "\" & ThisWorkbook.Name Then
        
        SourceFile = objFile
        SourceSheet = "Data"
        SourceRange = "A8:AC60000"
    
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "]"
    
        Set rsCon = CreateObject("ADODB.Connection")
        Set rsData = CreateObject("ADODB.Recordset")
        rsCon.Open szConnect
        rsData.Open szSQL, rsCon, 0, 1, 1

        If Not rsData.EOF Then
                [a60000].End(3).Offset(1).CopyFromRecordset rsData
        End If

        rsData.Close
        Set rsData = Nothing
        rsCon.Close
        Set rsCon = Nothing
        End If
    Next objFile
End Sub