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

Liên hệ QC

huynhphuong thcspt

Thành viên mới
Tham gia
31/8/18
Bài viết
45
Được thích
10
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
 

File đính kèm

  • 1_nhapphieudieutra_2021_1A.xls
    457.5 KB · Đọc: 32
  • 2_nhapphieudieutra_2021_1B.xls
    471 KB · Đọc: 19
  • 3_nhapphieudieutra_2021_1C.xls
    473 KB · Đọc: 18
  • 4_nhapphieudieutra_2021_1D.xls
    463 KB · Đọc: 17
  • 5_nhapphieudieutra_2021_1E.xls
    430 KB · Đọc: 17
  • 6_nhapphieudieutra_2021_CS.xls
    403 KB · Đọc: 17
  • TONG HOP.xlsm
    1,012.1 KB · Đọc: 24
Upvote 0
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.
 
Upvote 0
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:

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:

@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.
 
Lần chỉnh sửa cuối:
Upvote 0
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:


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é!
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Đườ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.
 
Upvote 0
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.
 
Upvote 0
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.
 

File đính kèm

  • Insert Shapes.xlsm
    16.9 KB · Đọc: 5
Upvote 0
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
 
Upvote 0
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ỉ.
 
Upvote 0
Upvote 0
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
 
Upvote 0
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.
 
Lần chỉnh sửa cuối:
Upvote 0
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.
 

File đính kèm

  • XEM PHIEU.xlsm
    3.3 MB · Đọc: 9
Upvote 0
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.
 

File đính kèm

  • XEM PHIEU_SQLinFILE_huynhphuong thcspt.xlsm
    3.3 MB · Đọc: 13
Upvote 0
Web KT
Back
Top Bottom