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

Liên hệ QC
Cho mình hỏi là nếu các file con có số cột khác nhau chỉ có cột tiêu đề là giống nhau thôi, vậy code sẽ chuyển thành gì để nó vẫn chạy được vậy bạn
 
Anh cho em hỏi nếu em muốn cập nhật dữ liệu từ dòng 6 của các file và cập nhật sang dòng 6 của file tổng thì sữa code như thế nào vậy anh.

Cám ơn.
 

File đính kèm

Lần chỉnh sửa cuối:
select * from [A6:E]
trước khi bắt đầu vòng lặp For thì xóa hết dữ liệu cũ trong file tổng hợp
 
doveandrose đã viết:
kiếm cái này
Mã: 
mRow = Sheet2.[B50000].End(xlUp).Row + 1

sửa lại thành
Mã: 
mRow = WorksheetFunction.Max(Sheet2.[B50000].End(xlUp).Row + 1, 6)
Nhấp chuột vào đây để mở rộng...
Cho mình hỏi "ngu" chút xíu, sửa thành như thế này có được không nhỉ?
mRow = Sheet2.[B50000].End(xlUp).Row + 5
P/s: Hông có ngồi trên máy nên hông test được. hehe
---------------------------------------------------
À, mình biết "ngu" ở chỗ nào rồi.
 
Lần chỉnh sửa cuối:
giangleloi đã viết:
Cho mình hỏi "ngu" chút xíu, sửa thành như thế này có được không nhỉ?
mRow = Sheet2.[B50000].End(xlUp).Row + 5
P/s: Hông có ngồi trên máy nên hông test được. hehe
Nhấp chuột vào đây để mở rộng...

khi nào bạn xuống xe vào nhà uống ly cafe , tải file nén kia về chạy thử với 3 file con là biết liền hà
 
Sửa vậy khi tổng hợp dữ liệu các file sẽ cách nhau 5 ô, mình không biết vba nhưng cũng mò thử trước rồi, mò nhiệt tình lắm nhưng không được mới nhờ giúp đỡ.

giangleloi đã viết:
Cho mình hỏi "ngu" chút xíu, sửa thành như thế này có được không nhỉ?
mRow = Sheet2.[B50000].End(xlUp).Row + 5
P/s: Hông có ngồi trên máy nên hông test được. hehe
---------------------------------------------------
À, mình biết "ngu" ở chỗ nào rồi.
Nhấp chuột vào đây để mở rộng...
 
saobekhonglac đã viết:
Sửa vậy khi tổng hợp dữ liệu các file sẽ cách nhau 5 ô, mình không biết vba nhưng cũng mò thử trước rồi, mò nhiệt tình lắm nhưng không được mới nhờ giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Bởi vậy mình mới nói là hỏi "ngu" chút xíu, chứ mình cũng như bạn mù tịt mấy khoản này luôn, nên chấp nhận chịu "ngu" để hỏi cho khôn ra ý.
 
Em chào cả nhà :)
Em định lập thớt nhưng nhân tiện có thớt này nên em hỏi luôn ở đây.
Lâu nay em có file tổng hợp dữ liệu từ nhiều file khác mà không cần mở file. Giờ em muốn chèn thêm 1 đoạn code để khi chạy macro này thì tạo luôn 1 đường link bên cạnh để ta bấm vào đó là mở được file kia ra.
Đoạn code cũ của em vẫn dùng đây ạ:
PHP: 
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function


Sub Danhsach_Thauphu()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Ma TP": RangeAddress = "B2:O2"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet3.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
        Cells.Select
         Range("A8").Activate
         Selection.EntireColumn.Hidden = False
         Range("A9:A10").Select
         MsgBox "HOÀN THÀNH!"
  End If
End Sub
Các bác giúp em với nhé, em cảm ơn nhiều ạ -=.,,
 
huycuongxd đã viết:
Em chào cả nhà :)
Em định lập thớt nhưng nhân tiện có thớt này nên em hỏi luôn ở đây.
Lâu nay em có file tổng hợp dữ liệu từ nhiều file khác mà không cần mở file. Giờ em muốn chèn thêm 1 đoạn code để khi chạy macro này thì tạo luôn 1 đường link bên cạnh để ta bấm vào đó là mở được file kia ra.
Đoạn code cũ của em vẫn dùng đây ạ:
PHP: 
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function


Sub Danhsach_Thauphu()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Ma TP": RangeAddress = "B2:O2"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet3.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
        Cells.Select
         Range("A8").Activate
         Selection.EntireColumn.Hidden = False
         Range("A9:A10").Select
         MsgBox "HOÀN THÀNH!"
  End If
End Sub
Các bác giúp em với nhé, em cảm ơn nhiều ạ -=.,,
Nhấp chuột vào đây để mở rộng...

Tôi chỉ thêm đường dẫn vào, chuyện còn lại bạn viết code để chuyển đường dẫn đó thành liên kết nhé.

Mã: 
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)            
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")
  
  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon
  
  szSQL = "SELECT [SIZE=4][COLOR=#ff0000][B]'" & FileName & "',[/B][/COLOR][/SIZE]* FROM [" & SheetName & RangeAddress & "];"
 
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function




Sub Danhsach_Thauphu()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Ma TP": RangeAddress = "B2:O2"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet3.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
        Cells.Select
         Range("A8").Activate
         Selection.EntireColumn.Hidden = False
         Range("A9:A10").Select
         MsgBox "HOÀN THÀNH!"
  End If
End Sub
 
Em cần thêm tên file đã ghép vào 1 cột mới ở mỗi dòng trong file tổng hợp. Các anh chị giúp em với. Thanks
 
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

bachloc1212
Đưa Text từ các dòng khác nhau về chung 1 dòng
Trả lời
9
Đọc
118
bachloc1212
bachloc1212
N
Sửa lỗi code vba khi chạy cho ra kết quả không đúng
Trả lời
6
Đọc
110
VetMini
V
D
Giúp đỡ thống kê dữ liệu theo điều kiện
Trả lời
5
Đọc
76
VetMini
V
Ha Manh-LD
  • Question Question
Lấy dữ liệu từ file csv
Trả lời
1
Đọc
74
ptm0412
ptm0412
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
2
Đọc
87
VetMini
V
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
13
Đọc
374
LuuAnh980
LuuAnh980
HeSanbi
  • Đã giải quyết
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
9
Đọc
808
HeSanbi
HeSanbi
Tienvinh191
  • Question Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
28
Đọc
2K
quyenpv
quyenpv
F
Hiển thị text trong Gantt chart (Google sheets)
Trả lời
0
Đọc
39
FATA11
F
Maika8008
  • Đã giải quyết
[Chia sẻ] Dùng VBA trộn dữ liệu Excel sang file Word mẫu (tương tự chức năng Mail Merge)
    • Thích
    • Yêu thích
    • Cảm ơn
25 26 27
Trả lời
522
Đọc
50K
Manhhung90
Manhhung90
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
5
Đọc
206
VetMini
V
C
  • Question Question
import data từ excel lên google sheet
Trả lời
5
Đọc
606
SonBDND
S
ptm0412
Chúc mừng năm mới Ất Tỵ 2025
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
1
Đọc
120
ptm0412
ptm0412
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
2
Đọc
937
thopd
T
mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
2
Đọc
118
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
307
Đọc
22K
kunkoi9390
K
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
6
Đọc
2K
tranhungdao12a3
T
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
45
Đọc
14K
ngocthu90
ngocthu90
Uyên dương Hoya
Lỗi định dạng font chữ trong excel
Trả lời
3
Đọc
141
ptm0412
ptm0412
T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
12
Đọc
474
VetMini
V
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom