Tổng hợp dữ liệu từ nhiều file excel vào 1 file

[huynhphuong thcspt]

Nhờ các bạn trên diễn đàn chỉnh lại (xem) dùm code sau. Mình không biết lỗi ở đâu mà cứ mỗi lần copy (dữ liệu) nhiều file vào 1 file thì 2 file đầu dữ liệu copy đúng, bất đầu từ file thứ 3 trở đi thì bị bỏ trống khoảng 4 dòng trở lên rồi mới copy dữ liệu vào. Chân thành cảm ơn.
CODE NHƯ SAU (sưu tầm trên điễn đàn):
Sub GopFileExcel()
'XOA DU LIEU TRUOC KHI TH

Sheets("DATA").Select
Range("A1:AZ1").EntireColumn.Delete
'KHAI BAO TH
Dim FilesToOpen
Dim x As Integer
Dim wb As Workbook
'LENH TH
On Error GoTo ErrHandler
Application.DisplayAlerts = False 'tat canh bao
Application.ScreenUpdating = False 'tat nhay man hinh
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", MultiSelect:=True, Title:="Files to Merge")

If MsgBox("Ban co muon chac tong hop du lieu dia ban khong?", vbYesNo) = vbYes Then 'canh bao tong hop dia ban

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If

x = 1
While x <= UBound(FilesToOpen)
Set wb = Workbooks.Open(Filename:=FilesToOpen(x))

If x = 1 Then
wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Range("A1")
Else
lr = ThisWorkbook.Sheets(1).UsedRange.Rows.Count
wb.Sheets(1).UsedRange.Offset(4).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
End If

wb.Close False
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True 'tat nhay man hinh
Application.DisplayAlerts = True 'tat canh bao
Set wb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler

End If 'ket thuc canh bao tong hop dia ban
End Sub

 

[Hoàng Tuấn 868]

Hi! Maika8008. Gần 1 tháng nay mình học hỏi từ kiến thức vba của bạn mới được 10% à,

Vậy 9 tháng nữa là bác Maika hết vốn.

 

[VetMini]

Vậy 9 tháng nữa là bác Maika hết vốn.

1. kiến thức học theo cấp số cộng sao?
2. bộ vốn bác ta nằm ì đó không tăng à?

Nhưng quan trọng hơn cả: câu ấy chỉ là câu nịnh thôi, ai mà biết thực sự người ta có học hay không.

 

[Hoàng Tuấn 868]

1. kiến thức học theo cấp số cộng sao?
2. bộ vốn bác ta nằm ì đó không tăng à?
Nhưng quan trọng hơn cả: câu ấy chỉ là câu nịnh thôi, ai mà biết thực sự người ta có học hay không.

Tỉ lệ tăng không ăn thua anh ạ, vốn tích lũy của bác Maika 30 năm nay giờ cộng thêm 1 năm nữa có lẽ không đáng kể. Tính trung bình thì 10% tương đương với 3 năm, vậy mà bây giờ chỉ 1 tháng đã học được, phần thêm 1 năm kia chắc chỉ vài hôm là xong nốt thôi anh.

 

[Maika8008]

@Thư Sinh Áo Trắng
Được chứ! Nhưng trước khi tôi trả lời, bạn chạy từng bước từng dòng code để tự trả lời đi đã.

 

[Thư Sinh Áo Trắng]

Buổi tối vui vẻ nhé! Cảm ơn bạn nhiều. Điều quan trọng là làm sao like mạnh nè thật tình mình không biết luôn.

Bài đã được tự động gộp: 15/5/21

Like mạnh nè View attachment 258700 = 2 x View attachment 258701

Giữ ngon tay vào chữ "Thích" dưới bài của người khác, nó hiện nhiều lựa chọn. Lúc chọn thả tim là like mạnh đấy.
Bác Mai cũng cháu nội cháu ngoại cả rồi bạn Thớt ạ.

Bài đã được tự động gộp: 26/5/21

@Thư Sinh Áo Trắng
Được chứ! Nhưng trước khi tôi trả lời, bạn chạy từng bước từng dòng code để tự trả lời đi đã.

Em có đánh dấu vào code, biết đó là phần code mở lên sự kiện pick file. Có đọc tài nguyên trên diễn đàn. Đa số code toàn pick chọn file nên em không học mót được. Thật lòng mong bác giúp cho đoạn code là đường dẫn cố định.

 

[Maika8008]

Giữ ngon tay vào chữ "Thích" dưới bài của người khác, nó hiện nhiều lựa chọn. Lúc chọn thả tim là like mạnh đấy.
Bác Mai cũng cháu nội cháu ngoại cả rồi bạn Thớt ạ.

Bài đã được tự động gộp: 26/5/21

Em có đánh dấu vào code, biết đó là phần code mở lên sự kiện pick file. Có đọc tài nguyên trên diễn đàn. Đa số code toàn pick chọn file nên em không học mót được. Thật lòng mong bác giúp cho đoạn code là đường dẫn cố định.

Tôi không ở trên máy tính nên không trả lời bạn ngay được. Mai nhé!

 

[Thư Sinh Áo Trắng]

Tôi không ở trên máy tính nên không trả lời bạn ngay được. Mai nhé!

Vâng. Cảm ơn bác @Maika8008

 

[Maika8008]

Em có đánh dấu vào code, biết đó là phần code mở lên sự kiện pick file. Có đọc tài nguyên trên diễn đàn. Đa số code toàn pick chọn file nên em không học mót được. Thật lòng mong bác giúp cho đoạn code là đường dẫn cố định.

Đường dẫn cố định
Sub lay_data_file_dong_sang_file_mo()
Dim cn As Object, rs As Object, strPath As String
Dim eRow&, includeList$, excludeList$, Sql$
With Sheet1
eRow = .Range("A" & Rows.Count).End(xlUp).Row
If eRow > 2 Then .Range("A2:C" & eRow).Clear
End With
' With Application.FileDialog(msoFileDialogFilePicker) '<--------- ch? này ch?nh thành du?ng d?n c? d?nh du?c không ??
' .Filters.Add "All Excel", "*.xls*"
' .AllowMultiSelect = False
' .Show
' If .SelectedItems.Count < 1 Then MsgBox ("Ban khong chon file nao"): Exit Sub
' If .SelectedItems.Count Then
strPath = ThisWorkbook.Path & "\" & "dang_dong.xlsm" 'Duong dan co dinh
On Error Resume Next
Set cn = CreateObject("adodb.connection")
cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & strPath & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
Sql = "SELECT * FROM [$A2:C] WHERE f1 is not Null"
Set rs = cn.Execute(Sql)
If Not rs.EOF Then Sheet1.Range("A2").CopyFromRecordset rs
rs.Close: cn.Close
Set rs = Nothing: Set cn = Nothing
On Error GoTo 0
' End If
'End With
End Sub

 

[Maika8008]

Hi! Maika8008. Gần 1 tháng nay mình học hỏi từ kiến thức vba của bạn mới được 10% à, chưa đủ công lực để giải quyết công việc của mình. Rất mong bạn chỉ dẫn thêm ( nội dung mô tả có trong file đính kèm á). Xin chân thành cảm ơn.

Chỗ: If NamS = arr(i, 6) Then 'tim nam sinh

Sửa thành: If NamS = arr(i, 6) And arr(i, 30) <> "" And arr(i, 31) <> "" Then

Lý do: Bạn chưa đặt điều kiện cho cột 30 và 31 phải có dữ liệu. Như câu của bạn, dù có bỏ học hay không, cứ sinh đúng năm arr(i, 6) thì lấy tuốt.

Ngoài ra chỗ này: NamS = IIf(Sheet2.Range("A7") <> "", Sheet2.Range("A7"), Sheet2.Range("B7"))
phải sửa thành:
If Sheet2.Range("A7") <> "" Then
NamS = Sheet2.Range("A7")
Else
MsgBox "Chua nhap nam sinh."
End If

 

[Thư Sinh Áo Trắng]

Đường dẫn cố định
Sub lay_data_file_dong_sang_file_mo()
Dim cn As Object, rs As Object, strPath As String
Dim eRow&, includeList$, excludeList$, Sql$
With Sheet1
eRow = .Range("A" & Rows.Count).End(xlUp).Row
If eRow > 2 Then .Range("A2:C" & eRow).Clear
End With
' With Application.FileDialog(msoFileDialogFilePicker) '<--------- ch? này ch?nh thành du?ng d?n c? d?nh du?c không ??
' .Filters.Add "All Excel", "*.xls*"
' .AllowMultiSelect = False
' .Show
' If .SelectedItems.Count < 1 Then MsgBox ("Ban khong chon file nao"): Exit Sub
' If .SelectedItems.Count Then
strPath = ThisWorkbook.Path & "\" & "dang_dong.xlsm" 'Duong dan co dinh
On Error Resume Next
Set cn = CreateObject("adodb.connection")
cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & strPath & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
Sql = "SELECT * FROM [$A2:C] WHERE f1 is not Null"
Set rs = cn.Execute(Sql)
If Not rs.EOF Then Sheet1.Range("A2").CopyFromRecordset rs
rs.Close: cn.Close
Set rs = Nothing: Set cn = Nothing
On Error GoTo 0
' End If
'End With
End Sub

Cảm ơn bác. Vậy là tất cả các dòng code đổi thành comment bỏ đi hết.

 

[huynhphuong thcspt]

Chỗ: If NamS = arr(i, 6) Then 'tim nam sinh

Sửa thành: If NamS = arr(i, 6) And arr(i, 30) <> "" And arr(i, 31) <> "" Then

Lý do: Bạn chưa đặt điều kiện cho cột 30 và 31 phải có dữ liệu. Như câu của bạn, dù có bỏ học hay không, cứ sinh đúng năm arr(i, 6) thì lấy tuốt.

Ngoài ra chỗ này: NamS = IIf(Sheet2.Range("A7") <> "", Sheet2.Range("A7"), Sheet2.Range("B7"))
phải sửa thành:
If Sheet2.Range("A7") <> "" Then
NamS = Sheet2.Range("A7")
Else
MsgBox "Chua nhap nam sinh."
End If

Báo cáo bạn Maika8008 chương trình chạy rất tốt. Nút gỡ vấn đề này nằm ở câu Code If NamS = arr(i, 6) And arr(i, 31) <> "" Then ...... Vậy mà mình suy nghĩ hoài không ra. Chân thành cảm ơn. Chúc bạn sức khỏe và hạnh phúc, chào bạn.

 

[huynhphuong thcspt]

Chào bạn Maika8008 ! Cuối tuần làm phiền bạn tí nha. Mình dùng Record Macro thu lại code như sau: (Mục đích là Insert Shapes hiện vào ô trống ngoài dữ liệu phía bên phải của dòng 1)
Sub InsertShape()
Range("A1").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Activate
ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, ActivateCell, 14.25, 40.5, 17.25).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "X"
End Sub
Khi thực hiện Macro thì chương trình chạy không đúng theo ý mình, Shape cứ hiện ở bên trái của dòng không hà. Mong bạn chỉ dẫn thêm. Cảm ơn.

 

[Maika8008]

Chào bạn Maika8008 ! Cuối tuần làm phiền bạn tí nha. Mình dùng Record Macro thu lại code như sau: (Mục đích là Insert Shapes hiện vào ô trống ngoài dữ liệu phía bên phải của dòng 1)
Sub InsertShape()
Range("A1").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Activate
ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, ActivateCell, 14.25, 40.5, 17.25).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "X"
End Sub
Khi thực hiện Macro thì chương trình chạy không đúng theo ý mình, Shape cứ hiện ở bên trái của dòng không hà. Mong bạn chỉ dẫn thêm. Cảm ơn.

Bạn đặt lại thuộc tính left của shape bằng với left của cell bạn muốn

 

[Hoàng Tuấn 868]

Chào bạn Maika8008 ! Cuối tuần làm phiền bạn tí nha. Mình dùng Record Macro thu lại code như sau: (Mục đích là Insert Shapes hiện vào ô trống ngoài dữ liệu phía bên phải của dòng 1)
Sub InsertShape()
Range("A1").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Activate
ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, ActivateCell, 14.25, 40.5, 17.25).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "X"
End Sub
Khi thực hiện Macro thì chương trình chạy không đúng theo ý mình, Shape cứ hiện ở bên trái của dòng không hà. Mong bạn chỉ dẫn thêm. Cảm ơn.

Vấn đề mới thì nên mở bài mới để bạn nào quan tâm đến còn tìm được chứ cứ chui hết vào một bài thế này thì tìm sao thấy được nhỉ.

 

[huynhphuong thcspt]

Bạn đặt lại thuộc tính left của shape bằng với left của cell bạn muốn

Do mình không rành lắm về vba nên vẫn chỉnh sửa code không được bạn ơi. Giúp mình với bạn ơi.

 

[Maika8008]

Do mình không rành lắm về vba nên vẫn chỉnh sửa code không được bạn ơi. Giúp mình với bạn ơi.

Nhiều lúc tôi mất 2 giờ chỉ để thử để biết các shape chấp nhận thuộc tính, phương thức gì, cách thức nó chấp nhận.

 

[huynhphuong thcspt]

Nhiều lúc tôi mất 2 giờ chỉ để thử để biết các shape chấp nhận thuộc tính, phương thức gì, cách thức nó chấp nhận.

Báo cáo bạn MaiKa8008, Vẫn theo hướng chỉ dẫn của bạn là " đặt lại thuộc tính left của shape bằng với left của cell bạn muốn" cuối cùng mình đã làm được rồi, Cảm ơn bạn nhiều ! Đây là đoạn code vừa chỉnh xong:
Sub InsertShape1()

Range("A1").Select
Selection.End(xlToRight).Select
ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, ActiveCell.Offset(0, 1).Left, 14.25, 40.5, 25.25).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "X"

End Sub

 

[Maika8008]

Báo cáo bạn MaiKa8008, Vẫn theo hướng chỉ dẫn của bạn là " đặt lại thuộc tính left của shape bằng với left của cell bạn muốn" cuối cùng mình đã làm được rồi, Cảm ơn bạn nhiều ! Đây là đoạn code vừa chỉnh xong:
Sub InsertShape1()

Range("A1").Select
Selection.End(xlToRight).Select
ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, ActiveCell.Offset(0, 1).Left, 14.25, 40.5, 25.25).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "X"

End Sub

Rất mừng là bạn đã có nhiều cố gắng. Đúng rồi, bạn đã tạo ra được hình mũi tên chỉ sang trái và nằm ở cạnh trái của ô B1 (Vì ban đầu là Range("A1").Select, sau đó ActiveCell.Offset(0, 1).Left là sang bên trái 1 ô -> B1).
Tuy nhiên thừa 1 dòng: Selection.End(xlToRight).Select chỉ để dời ô hiện hành sang phải 1 khoảng xlToRight chứ không dính gì đến cái dấu mũi tên kia.

Bây giờ tôi gửi cho bạn 1 đoạn code có trong 1 ứng dụng của tôi (chỉ có dòng đầu là tôi lấy của bạn, sửa lại 1 chút chỗ LEFT).
Sub TaoNutIn()
ActiveSheet.Shapes.AddShape(msoShapeRightArrow, 105, 14.25, 40.5, 25.25).Select
Selection.ShapeRange.Left = Range("F1").Left 'hoac Right cua cell
Selection.ShapeRange.Top = Range("F5").Top 'hoac Bottom cua 1 cell
Selection.ShapeRange.Height = 41 'Hoac Range("XX").RowHeight
Selection.ShapeRange.Width = 89 'Hoac Range("XX").ColumnWidth
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "IN PHIEU"
End Sub

Đấy bạn xem, sau khi đã tao ra 1 shape (dù nó được tạo ra ở vị trí nào) thì muốn dời nó đi đâu mình chỉ ra rõ ràng.

 

[huynhphuong thcspt]

Chào bạn Maika8008! Khi nào bạn rảnh giúp mình 1 vấn đền này nha. Đối với mình thì vượt quá khả năng.
Xem thông tin số phiếu từ sheet(DATA) (sheet(DATA) là file tổng hợp từ nhiều file thành 1 file).
Mọi chi tiết mô tả ở file đính kèm. Cảm ơn ! Chúc Maika8008 sức khỏe và hạnh phục.

 

[Maika8008]

Chào bạn Maika8008! Khi nào bạn rảnh giúp mình 1 vấn đền này nha. Đối với mình thì vượt quá khả năng.
Xem thông tin số phiếu từ sheet(DATA) (sheet(DATA) là file tổng hợp từ nhiều file thành 1 file).
Mọi chi tiết mô tả ở file đính kèm. Cảm ơn ! Chúc Maika8008 sức khỏe và hạnh phục.

Thử file. Bấm nút để chạy code.