Tổng hợp dữ liệu từ nhiều File vào 1 file Tong.xls (1 người xem)

[Hoacomay96]

Xin chào các tiền bối. Tôi muốn copy vùng dữ liệu ở sheet1 từ các files có tên là TXT_1, TXT_2, TXT3 ,....DN_500 trong cùng thư mục và có cấu trúc dữ liệu như nhau dán vào 1 file mới tên là "Tong.xls ". Vùng dữ liệu được dán từ file 1 đến hết, và tự động đếm số dòng trong file tổng. Tôi có file dữ liệu và code đính kèm, mong các tiền bối sửa giúp. Xin cám ơn rất nhiều.

 

[cuongtuyen]

- Bạn để các files có tên là TXT_1, TXT_2, TXT3 ,....DN_500 vào cùng 1 thư mục (*.xls).
- Trong File Tong.xls bạn thêm đoạn Code sau:

Option Explicit
Sub Example5()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim n As Long, rNum As Long
 
Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant
 
SaveDriveDir = CurDir
MyPath = "D:\"
ChDrive MyPath
ChDir MyPath
 
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", MultiSelect:=True)
If IsArray(FName) Then
    Application.ScreenUpdating = False
    
    Set basebook = ActiveWorkbook
    rNum = 1
            
    For n = LBound(FName) To UBound(FName)
        Set mybook = Workbooks.Open(FName(n))
        
        'Day chinh la vung ma ban can copy (Vung [B][COLOR=red]A10:E20[/COLOR][/B] trong sheet co ten la Sheet1
        Set sourceRange = mybook.Worksheets("Sheet1").[COLOR=red][B]Range("A10:E20")[/B][/COLOR]
        rNum = (n - 1) * sourceRange.Rows.Count + 1
                
        'Xac dinh o de copy
        Set destrange = basebook.Worksheets("Sheet1").Cells(rNum, "A")
                   
        With sourceRange
            Set destrange = basebook.Worksheets("Sheet1").Cells(rNum, "A").Resize(.Rows.Count, .Columns.Count)
        End With
        destrange.Value = sourceRange.Value
        
        'Dong file
        mybook.Close False
        
    Next n
End If
'Tra ve mac dinh truoc khi mo
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Chạy marco trên, chọn tất cả các files chứa dữ liệu, rồi nhấn Open...

Xin chao bác: em thấy cách làm của bác rất hay nhưng em muốn copy dữ liệu theo cột thì là thế nào mong bác giúp đỡ

 

[lecongquan]

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=MyPath & "tong.xls", FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False

Đoạn Code trên tuy không kiểm tra file tong.xls đã tồn tại hay chưa nhưng do yêu cầu của bạn là tạo 1 file tong.xls mới hoàn toàn nên mình sử dụng luôn tính năng tạo mới 1 Workbook và ghi thành file tong.xls. Như vậy nếu file tong.xls đã có thì cũng bị ghi đè.


Bạn thử dùng đoạn code sau:

Option Explicit
Sub Example5()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim n As Long, rNum As Long
 
Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant
 
SaveDriveDir = CurDir
MyPath = "D:\TXT\"
ChDrive MyPath
ChDir MyPath
 
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=MyPath & "tong.xls", FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
 
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", MultiSelect:=True)
If IsArray(FName) Then
    Set basebook = ActiveWorkbook
    rNum = 1
 
    For n = LBound(FName) To UBound(FName)
        Set mybook = Workbooks.Open(FName(n))
 
        Set sourceRange = mybook.Worksheets("Sheet1").[B][COLOR=red]UsedRange[/COLOR][/B][COLOR=red]
[/COLOR]       rNum = (n - 1) * sourceRange.Rows.Count + 1
 
        'Xac dinh o de copy
        Set destrange = basebook.Worksheets("Sheet1").Cells(rNum, "A")
 
        With sourceRange
            Set destrange = basebook.Worksheets("Sheet1").Cells(rNum, "A").Resize(.Rows.Count, .Columns.Count)
        End With
        destrange.Value = sourceRange.Value
 
        'Dong file
        mybook.Close False
 
    Next n
End If
'Tra ve mac dinh truoc khi mo
ChDrive SaveDriveDir
ChDir SaveDriveDir
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

Chào các bác. Các bác cho em hỏi, nếu bây giờ mỗi file của em thì cái sheet 1 nó có nhiều tên khác nhau. Làm sao để file tổng cứ lấy sheet 1 thôi, không cần quan tâm là sheet 1 tên là gì. Chân thành cám ơn các bác.

 

[pmhoang]

Chào các bác. Các bác cho em hỏi, nếu bây giờ mỗi file của em thì cái sheet 1 nó có nhiều tên khác nhau. Làm sao để file tổng cứ lấy sheet 1 thôi, không cần quan tâm là sheet 1 tên là gì. Chân thành cám ơn các bác.

Trong code bạn thấy dòng nay
Worksheets("Sheet1"), nghĩa là sheet1, bạn thay bằng số 1 (số thứ tự của sheet từ trái sang phải) không quan tam đến tên sheet là gì.
Bạn sửa lại là Worksheets(1) là được như ý bạn.

 

[xuan_nam]

Tôi muốn kiểm tra xem nếu dòng cuối còn dữ liệu thì chọn tiếp để copy thì sửa code thế nào ạ. Ví dụ File 1: vùng dữ liệu b7:v8, File 2 kiểm tra ô b9 trở đi, nếu b9 có dữ liệu thì vùng chọn là "b7:v9" nếu không thì trở lại vùng b7:v8, kiểm b10, b11, b12... cho đến khi không còn dữ liệu. Nhờ cao nhân giúp đỡ.

 

[xuan_nam]

Tôi muốn kiểm tra xem nếu dòng cuối còn dữ liệu thì chọn tiếp để copy thì sửa code thế nào ạ. Ví dụ File 1: vùng dữ liệu b7:v8, File 2 kiểm tra ô b9 trở đi, nếu b9 có dữ liệu thì vùng chọn là "b7:v9" nếu không thì trở lại vùng b7:v8, kiểm b10, b11, b12... cho đến khi không còn dữ liệu. Nhờ cao nhân giúp đỡ..

Tôi dùng đoạn code này nó báo lỗi, có Pro nào chỉ giúp với không.
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim n As Long, rNum As Long
Dim i, j As Integer


Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant


SaveDriveDir = CurDir
MyPath = "D:\TXT"
ChDrive MyPath


With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With


FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", MultiSelect:=True)
If IsArray(FName) Then
Set basebook = ActiveWorkbook
rNum = 1

For n = LBound(FName) To UBound(FName)
Set mybook = Workbooks.Open(FName(n))
'Tong hop TH Lop,HS,CBGVNv
Set sourceRange = mybook.Worksheets("Diem_truong").Range("b7:v8")
i = 2
For j = 9 To 20
If Sheets("Diem_truong").Cells("i", "J") <> "" Then
Set sourceRange = mybook.Worksheets("Diem_truong").Range("b7:""x" & "j")
End If
Next j
rNum = (n - 1) * sourceRange.Rows.Count + 9
'Xac dinh o de copy
With sourceRange
Set destrange = basebook.Worksheets("Diem_truong").Cells(rNum, "b").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
'Dong file
mybook.Close False
Next n
End If
'Tra ve mac dinh truoc khi mo
ChDrive SaveDriveDir
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

 

[xuan_nam]

Cảm ơn bạn hpkhuong rất nhiều!
Nhưng yêu cầu của tôi thế này bạn ạ: ở File "TH1" lấy vùng B7:v9; TH2 lấy B7:v12; th3 lấy B7:b8 (còn nhiều file khác cùng cáu trúc nữa, giống file TH1, TH2) dán liên tiếp vào sheet "11.CT mam non" của File copytong, từ dòng b7. có file đính kèm. Mong bạn giúp đỡ.

 

[doveandrose]

Option Explicit
Sub GPE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ChonO As Object, ChonF As Object, pFile, Path, lr&, lr2&
Dim fil As Object, Data, Wb As Workbook, Sh As Worksheet, WsMain As Worksheet
pFile = ActiveWorkbook.Name
Set WsMain = ActiveWorkbook.Sheets("11.CT mam non")
WsMain.Range("B7:V65000").ClearContents
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "CHON FOLDER"
    .Show
    Path = .SelectedItems(1) & "\"
End With
Set ChonO = CreateObject("scripting.filesystemobject")
Set ChonF = ChonO.GetFolder(Path)
For Each fil In ChonF.Files
    If InStr(1, fil.Name, pFile) <= 0 Then
        Set Wb = Workbooks.Open(fil.Path)
        Set Sh = Wb.Worksheets("Diem_truong")
        [COLOR=#ff0000][SIZE=4][B]lr2 = Sh.Range("C65000").Row[/B][/SIZE][/COLOR]
        Data = Sh.Range("B7:V" & lr2)
        Workbooks(fil.Name).Close
        lr = [C65000].End(3).Row
        WsMain.Range("B" & lr).Offset(1).Resize(UBound(Data), UBound(Data, 2)) = Data
    End If
Next fil
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

này là gì đây anh ?

Tôi muốn kiểm tra xem nếu dòng cuối còn dữ liệu thì chọn tiếp để copy thì sửa code thế nào ạ. Ví dụ File 1: vùng dữ liệu b7:v8, File 2 kiểm tra ô b9 trở đi, nếu b9 có dữ liệu thì vùng chọn là "b7:v9" nếu không thì trở lại vùng b7:v8, kiểm b10, b11, b12... cho đến khi không còn dữ liệu. Nhờ cao nhân giúp đỡ.

khi nào buồn buồn chạy cái này chơi

Public Sub hell()
Dim pFile, filename, Adr As String, lr, fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
pFile = Application.GetOpenFilename("hello (*.xls*), *xls*", , , , True)
If TypeName(pFile) = "Variant()" Then
    With Sheet7
        .Range("B7:V10000").ClearContents
        For Each filename In pFile
            Adr = "'" & fso.GetParentFolderName(filename) & "\[" & _
            fso.GetFileName(filename) & "]Diem_truong'!"
            .[BA1] = "=IFERROR(LOOKUP(2,1/(" & Adr & "B1:B10000<>""""),ROW(A1:A10000)),0)"
            lr = .[BA1]
            If lr > 6 Then
                .Range("BB1").Resize(lr - 6, 21).FormulaArray = "=if(" & Adr & "B7:V" & lr & _
                "="""",""""," & Adr & "B7:V" & lr & ")"
                .Range("B" & WorksheetFunction.Max(7, .[B65000].End(xlUp).Row + 1)).Resize( _
                lr - 6, 21).Value = .Range("BB1").Resize(lr - 6, 21).Value
                .Range("BA1").Resize(lr - 6, 22).ClearContents
            End If
        Next
    End With
End If
End Sub

 

[giangleloi]

này là gì đây anh ?

Chắc anh ý cố tình luyện mắt cho "thánh soi" thôi.

 

[doveandrose]

Chết...Lỗi đánh máy. hic hic....
Công nhận không hỗ danh bạn í là "Thánh Soi ở GPE"

ấy đi đâu vội vậy , chưa hết film mà . Giờ chạy code , 1 cửa sổ chọn Folder hiện ra , người dùng bấm nút Cancel thì sao ?

 

[giangleloi]

Chết...Lỗi đánh máy. hic hic....
Công nhận không hỗ danh bạn í là "Thánh Soi ở GPE"

Lại bị soi nữa rồi kìa, bẫy nốt lỗi đi. haha

 

[doveandrose]

Có 1 dòng On Error Resume Next này bạn ấy cũng không tha...
-------------------
Hoặc thêm đoạn này được chưa đồng chí.

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "CHON FOLDER"
    .Show
   [COLOR=#ff0000] If .SelectedItems.Count = 0 Then Exit Sub[/COLOR] 'thêm dòng bẫy lỗi này...
    Path = .SelectedItems(1) & "\"
End With
WsMain.Range("B7:V65000").ClearContents 'chuyển ra đằng sau (lúc đầu nó nằm ở trên)

tôi mà là bạn , bị cái tên nói xàm kia trêu chọc hoài , ghét mặt lôi đoạn code #29 ra kiếm có lỗi gì bắt bẻ lại hắn cho bõ ghét . hi hi

 

[xuan_nam]

Cảm ơn tất cả mọi người đã chỉ giúp. Nhưng tôi chỉ muốn dán vào mẫu định sẵn. nếu có thể kiểm tra file copy tổng mà đến dòng cuối cùng thì chèn thêm dòng và dán vào thì sao nhỉ?. Bạn hpkhuong chỉ dùm được không ạ.

 

[xuan_nam]

Hỏi về code

Cảm ơn tất cả mọi người đã chỉ giúp. Cũng yêu cầu như trên nhưng tôi chỉ muốn dán vào vùng định sẵn trong File copy tong. Nếu đến dòng cuối (trong file là dòng 27) thì có thể kiểm tra chèn thêm dòng và dán vào được không bạn. Bạn hpkhuong chỉ dùm được không ạ?