Tổng hợp dữ liệu từ nhiều sheets trên nhiều file (1 người xem)

kokano90 · 3/10/19

Gửi các Thầy cô
Em muốn nhờ các cô tổng code tổng hợp giúp em dữ liệu từ nhiều sheet của nhiều file cùng lúc với ạ
Hiện tại em có demo thử 3 file
1, 2 và Tong hop
Trong file tổng hợp em muốn lấy dữ liệu của 2 cột trên 2 sheet KASHITO và KENCHITAI của 2 file "1" & "2"
Em cũng trình bày trong file Tong hop rồi ạ
Mong các thầy giúp đỡ ạ

HieuCD · 3/10/19

kokano90 đã viết:
Gửi các Thầy cô
Em muốn nhờ các cô tổng code tổng hợp giúp em dữ liệu từ nhiều sheet của nhiều file cùng lúc với ạ
Hiện tại em có demo thử 3 file
1, 2 và Tong hop
Trong file tổng hợp em muốn lấy dữ liệu của 2 cột trên 2 sheet KASHITO và KENCHITAI của 2 file "1" & "2"
Em cũng trình bày trong file Tong hop rồi ạ
Mong các thầy giúp đỡ ạ

Chạy code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, S, fRow&, eRow&
    
  Application.ScreenUpdating = False
  Set sh = Sheets("A")
  eRow = sh.Range("B" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 1 Then sh.Range("A2:C" & eRow).ClearContents 'Xoa du lieu cu
 
  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xlsx", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    fRow = eRow + 1
    Set rs = cn.Execute("select * from [KASHITO$A11:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    Set rs = cn.Execute("select * from [KENCHITAI$A12:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    S = Split(oFile, "\")
    S = Split(S(UBound(S)), ".x")(0)
    sh.Range("C" & fRow & ":C" & eRow) = S
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

befaint · 3/10/19

Mới copy được..

kokano90 · 3/10/19

HieuCD đã viết:

Chạy code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, S, fRow&, eRow&
   
  Application.ScreenUpdating = False
  Set sh = Sheets("A")
  eRow = sh.Range("B" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 1 Then sh.Range("A2:C" & eRow).ClearContents 'Xoa du lieu cu

  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xlsx", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    fRow = eRow + 1
    Set rs = cn.Execute("select * from [KASHITO$A11:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    Set rs = cn.Execute("select * from [KENCHITAI$A12:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    S = Split(oFile, "\")
    S = Split(S(UBound(S)), ".x")(0)
    sh.Range("C" & fRow & ":C" & eRow) = S
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

Cám ơn thầy ạ. Mai em test rồi báo lại kết quả ạ

Bài đã được tự động gộp: 3/10/19

befaint đã viết:
Mới copy được..

Em cảm ơn ạ

VetMini · 3/10/19

HieuCD đã viết:

Chạy code

Mã:

Sub ABC()
...
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    fRow = eRow + 1
    Set rs = cn.Execute("select * from [KASHITO$A11:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    Set rs = cn.Execute("select * from [KENCHITAI$A12:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & eRow + 1).CopyFromRecordset rs
    rs.Close:    cn.Close
...

Hai câu trên có thể gộp thành 1 với "UNION ALL". Trừ phi gộp xong thì bị nhiều hơn 65000

HieuCD đã viết:
... S = Split(oFile, "\")
S = Split(S(UBound(S)), ".x")(0)
...

Lỡ gặp file tên là abc.xyz.xlsx thì sao?

HieuCD · 4/10/19

VetMini đã viết:
Hai câu trên có thể gộp thành 1 với "UNION ALL". Trừ phi gộp xong thì bị nhiều hơn 65000

Lỡ gặp file tên là abc.xyz.xlsx thì sao?

Tên file là số chuyến nên loại trừ khả năng gặp dạng đặc biệt
Khi dùng "Set rs = cn.Execute(" sẽ lấy nhiều hơn 65000 dòng với Excel 2007 về sau, ví dụ file "1.xls" đã thêm dữ liệu

Mã:

Sub ABC2()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, S, fRow&, eRow&
    
  Application.ScreenUpdating = False
  Set sh = Sheets("A")
  eRow = sh.Range("B" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 1 Then sh.Range("A2:C" & eRow).ClearContents 'Xoa du lieu cu
 
  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xlsx", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    fRow = sh.Range("B" & Rows.Count).End(xlUp).Row + 1
    Set rs = cn.Execute("select * from [KASHITO$A11:B65000] where f2 is not null union all select * from [KENCHITAI$A12:B65000] where f2 is not null")
    If Not rs.EOF Then sh.Range("A" & fRow).CopyFromRecordset rs
    rs.Close:    cn.Close
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    S = Split(oFile, "\")
    sh.Range("C" & fRow & ":C" & eRow) = Split(S(UBound(S)), ".xls")(0)
  Next
  Set cn = Nothing: Set rs = Nothing
  Application.ScreenUpdating = True
End Sub

kokano90 · 4/10/19

HieuCD đã viết:
Tên file là số chuyến nên loại trừ khả năng gặp dạng đặc biệt
Khi dùng "Set rs = cn.Execute(" sẽ lấy nhiều hơn 65000 dòng với Excel 2007 về sau, ví dụ file "1.xls" đã thêm dữ liệu

HieuCD đã viết:
Ch?y code

Em cám on thầy. Test thử thấy chạy được rồi. Còn cái vụ tên file nhu thầy @VetMini nói. Em sẽ cố gắng tránh đặt tên có liên quan tới cái thầy nói
Còn vấn đề này nữa. Nhờ thầy giúp ạ. Khi lấy dữ liệu được rồi. ở cột A (SP) ấy ạ. Dữ liệu bị cách quãng. Có cách nào lấp đầy nó luôn ( những dòng trống ở duới bằng dòng có dữ liệu ở trên) không ?
Tiện dây cũng nhờ các thầy cô giúp luôn cho trót ?. Mục đích em lấy dữ liệu vậy là để so sánh
Có cách nào so sánh sau đó làm đổ màu những mã có SP và Số LOT giống nhau như trong file được không ạ thầy?
cám ơn các thầy cô nhiều ạ

HieuCD · 4/10/19

kokano90 đã viết:
Em cám on thầy. Test thử thấy chạy được rồi. Còn cái vụ tên file nhu thầy @VetMini nói. Em sẽ cố gắng tránh đặt tên có liên quan tới cái thầy nói
Còn vấn đề này nữa. Nhờ thầy giúp ạ. Khi lấy dữ liệu được rồi. ở cột A (SP) ấy ạ. Dữ liệu bị cách quãng. Có cách nào lấp đầy nó luôn ( những dòng trống ở duới bằng dòng có dữ liệu ở trên) không ?
Tiện dây cũng nhờ các thầy cô giúp luôn cho trót ?. Mục đích em lấy dữ liệu vậy là để so sánh
Có cách nào so sánh sau đó làm đổ màu những mã có SP và Số LOT giống nhau như trong file được không ạ thầy?
cám ơn các thầy cô nhiều ạ

Chưa hiểu qui luật đổ màu 2 ô trong file, giải thích rỏ

kokano90 · 4/10/19

HieuCD đã viết:
Chưa hiểu qui luật đổ màu 2 ô trong file, giải thích rỏ

sau khi chạy đoạn code trên của thầy. ở cột A dữ liệu bị ngắt quãng. em muốn ô nào trống thì bằng những ô trên nó có dữ liệu rồi so sánh ở 2 mảng dữ liệu ấy. cứ cái nào cùng sản phẩm, cùng số lot thì đổ màu để biết ạ

HieuCD · 4/10/19

kokano90 đã viết:
Em cám on thầy. Test thử thấy chạy được rồi. Còn cái vụ tên file nhu thầy @VetMini nói. Em sẽ cố gắng tránh đặt tên có liên quan tới cái thầy nói
Còn vấn đề này nữa. Nhờ thầy giúp ạ. Khi lấy dữ liệu được rồi. ở cột A (SP) ấy ạ. Dữ liệu bị cách quãng. Có cách nào lấp đầy nó luôn ( những dòng trống ở duới bằng dòng có dữ liệu ở trên) không ?
Tiện dây cũng nhờ các thầy cô giúp luôn cho trót ?. Mục đích em lấy dữ liệu vậy là để so sánh
Có cách nào so sánh sau đó làm đổ màu những mã có SP và Số LOT giống nhau như trong file được không ạ thầy?
cám ơn các thầy cô nhiều ạ

Chạy code

Mã:

Sub ABC()
  Dim cn As Object, rs As Object
  Dim sFile, oFile, sh As Worksheet, S, fRow&, eRow&
  Dim sArr, Res(), i&, sR&, tmp$
  Application.ScreenUpdating = False
  Set sh = Sheets("A")
  eRow = sh.Range("B" & Rows.Count).End(xlUp).Row 'Dong cuoi, Xoa du lieu cu
  If eRow > 1 Then sh.Range("A2:C" & eRow).Clear 'Xoa du lieu cu
 
  sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xlsx", _
                                        Title:="Select File", MultiSelect:=True)
  If VarType(sFile) = vbBoolean Then MsgBox ("Chua chon File du lieu"): Exit Sub
  Set cn = CreateObject("adodb.connection")
  For Each oFile In sFile
    If Val(Application.Version) < 12 Then
      cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & oFile & ";Extended Properties=""Excel 8.0;HDR=No"";")
    Else
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & oFile & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    End If
    fRow = sh.Range("B" & Rows.Count).End(xlUp).Row + 1
    Set rs = cn.Execute("select * from [KASHITO$A11:B65000] where f2 is not null union all select * from [KENCHITAI$A12:B65000] where f2 is not null")
    If Not rs.EOF() Then
      sArr = rs.GetRows
      sR = UBound(sArr, 2)
      ReDim Res(0 To sR, 0 To 1)
      For i = 0 To sR
        If Len(sArr(0, i)) Then tmp = sArr(0, i)
        Res(i, 0) = tmp
        Res(i, 1) = sArr(1, i)
      Next i
    End If
    rs.Close:    cn.Close
    sh.Range("A" & fRow).Resize(sR + 1, 2) = Res
    eRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    S = Split(oFile, "\")
    sh.Range("C" & fRow & ":C" & eRow) = Split(S(UBound(S)), ".xls")(0)
  Next
  Set cn = Nothing: Set rs = Nothing
  Call SoSanh
  Application.ScreenUpdating = True
End Sub
Private Sub SoSanh()
  Dim sArr(), tArr(), Res(), i&, ik&, sR&, iKey$
  With Sheets("A")
    .UsedRange.Interior.ColorIndex = 0
    sArr = .Range("A1", .Range("B" & Rows.Count).End(xlUp)).Value
    tArr = .Range("H1", .Range("I" & Rows.Count).End(xlUp)).Value
  End With
  With CreateObject("scripting.dictionary")
    sR = UBound(sArr)
    For i = 1 To sR
      iKey = sArr(i, 1) & "#" & sArr(i, 2)
      .Item(iKey) = i
    Next i
    sR = UBound(tArr)
    For i = 1 To sR
      iKey = tArr(i, 1) & "#" & tArr(i, 2)
      ik = .Item(iKey)
      If ik > 0 Then
        Sheets("A").Range("A" & ik).Resize(, 2).Interior.ColorIndex = 12
        Sheets("A").Range("H" & i).Resize(, 2).Interior.ColorIndex = 12
      End If
    Next i
  End With
End Sub

kokano90 · 4/10/19

Thầy ơi. Nếu thay vì đổ màu ở 2 mảng. mà cái nào trùng thì em muốn xóa cái trùng đó ở mảng H:I đi được không ạ

befaint · 4/10/19

kokano90 đã viết:
được không

KHÔNG được!

Bạn không nên chơi trò "treo củ cải trước mũi" như vậy. Bạn có yêu cầu gì thì nêu hết luôn một lượt từ đầu để mọi người giúp bạn.
Mặc dù có người rất kiên nhẫn giúp bạn nhưng bạn không nên làm vậy, chúng ta nên tôn trọng nhau.

Ngoài ra, tới bài #6 là kết thúc chủ đề này rồi. Bạn muốn làm gì khác thêm phải đăng chủ đề mới. Các bài từ bài #7 trở đi vi phạm nội quy mục II.5:
"5. Bài viết phải được gửi (post) ở đúng vị trí, đúng mục (box) và đúng chủ đề (topic). "

kokano90 · 4/10/19

befaint đã viết:
KHÔNG được!

Bạn không nên chơi trò "treo củ cải trước mũi" như vậy. Bạn có yêu cầu gì thì nêu hết luôn một lượt từ đầu để mọi người giúp bạn.
Mặc dù có người rất kiên nhẫn giúp bạn nhưng bạn không nên làm vậy, chúng ta nên tôn trọng nhau.

Ngoài ra, tới bài #6 là kết thúc chủ đề này rồi. Bạn muốn làm gì khác thêm phải đăng chủ đề mới. Các bài từ bài #7 trở đi vi phạm nội quy mục II.5:
"5. Bài viết phải được gửi (post) ở đúng vị trí, đúng mục (box) và đúng chủ đề (topic). "

Em xin lỗi. Em sẽ rút kinh nghiệm. Cám ơn Thầy @HieuCD và các anh chị nhiều. Code trên đã đáp ứng đủ nhu cầu của em rồi ạ.

Tổng hợp dữ liệu từ nhiều sheets trên nhiều file (1 người xem)

Người dùng đang xem chủ đề này

kokano90

Thành viên hoạt động

File đính kèm

HieuCD

Chuyên gia GPE

File đính kèm

befaint

|||||||||||||

File đính kèm

kokano90

Thành viên hoạt động

VetMini

Đang đi tìm hòn đá

HieuCD

Chuyên gia GPE

File đính kèm

kokano90

Thành viên hoạt động

File đính kèm

HieuCD

Chuyên gia GPE

kokano90

Thành viên hoạt động

File đính kèm

HieuCD

Chuyên gia GPE

kokano90

Thành viên hoạt động

befaint

|||||||||||||

kokano90

Thành viên hoạt động

Bài viết mới nhất

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

Thời gian đếm ngược.