Hỏi về copy liên tiếp dữ liệu theo chiều ngang từ nhiều File excel

Liên hệ QC
H

hoahuongduong1986

Thành viên thường trực
Tham gia
14/11/18
Bài viết
346
Được thích
40
Kính gửi các Anh chị trên diễn đàn,
Em có một câu hỏi về sử dụng VBA nhờ các anh chị cho xin hướng dẫn Code với ạ. Vì em phải tổng hợp theo ngày của cả năm nên nếu phải Copy sẽ thực hiện rất mất thời gian mà còn sót và sai nữa. Nhờ các anh chị bớt chút time cho em xin Code hoặc code phù hợp với ạ. Em xin miêu tả như sau để mọi người hướng dẫn ạ.

Em nhiều File giống nhau về hình thức và giờ em muốn copy số liệu từ 100 File này vào một File tên là File Tong hop như hình (Các File e đã để trong đường dẫn như hình em chụp).
Số liệu từ D18 - D24 em muốn được Copy theo chiều ngang liên tục theo chiều ngang vào File Tong hop tu D18 - E 18- F18...đến hết toàn bộ số liệu các File trong Folder ạ. Nếu được thì ở D17, E17, F17.... sẽ lấy dược tựa đề là ngày ví dụ File F1-20181002-ST-M-01 thì lấy được 20181002 ạ hoạc không cũng không sao - sẽ điền tay phần này ạ. Kính nhờ các Anh chị và các bạn trợ giúp ạ. Cảm ơn mọi người ạ !
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
hoahuongduong1986 đã viết:
Kính gửi các Anh chị trên diễn đàn,
Em có một câu hỏi về sử dụng VBA nhờ các anh chị cho xin hướng dẫn Code với ạ. Vì em phải tổng hợp theo ngày của cả năm nên nếu phải Copy sẽ thực hiện rất mất thời gian mà còn sót và sai nữa. Nhờ các anh chị bớt chút time cho em xin Code hoặc code phù hợp với ạ. Em xin miêu tả như sau để mọi người hướng dẫn ạ.

Em nhiều File giống nhau về hình thức và giờ em muốn copy số liệu từ 100 File này vào một File tên là File Tong hop như hình (Các File e đã để trong đường dẫn như hình em chụp).
Số liệu từ D18 - D24 em muốn được Copy theo chiều ngang liên tục theo chiều ngang vào File Tong hop tu D18 - E 18- F18...đến hết toàn bộ số liệu các File trong Folder ạ. Nếu được thì ở D17, E17, F17.... sẽ lấy dược tựa đề là ngày ví dụ File F1-20181002-ST-M-01 thì lấy được 20181002 ạ hoạc không cũng không sao - sẽ điền tay phần này ạ. Kính nhờ các Anh chị và các bạn trợ giúp ạ. Cảm ơn mọi người ạ !
Nhấp chuột vào đây để mở rộng...
Các file cùng thư mục
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), cn As Object
  Dim iPath As String, sqlStr As String
  Dim i As Long, j As Byte
  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr), 0 To 7)
  sqlStr = "select f1 from [G023311$D18:D24]"
  Set cn = CreateObject("ADODB.Connection")
  For i = LBound(fileArr) To UBound(fileArr)
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(i) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
    For j = LBound(sArr, 2) To UBound(sArr, 2)
      Res(i, j + 1) = sArr(0, j)
    Next j
    Res(i, 0) = Split(fileArr(i), "-")(1)
    cn.Close
  Next i
  Range("C18:J18").Resize(i - 1) = Res
  Set cn = Nothing
End Sub

Function GetFileList(ByVal StrFolder As String, Optional MainFile As String = "")
  Dim fso As Object, ObjFile As Object
  Dim Res(), k As Long, tmp As String
  Set fso = CreateObject("Scripting.FileSystemObject")
  With fso.GetFolder(StrFolder)
    For Each ObjFile In .Files
      If fso.GetExtensionName(ObjFile) Like "xls*" Then
        tmp = ObjFile.Name
        If tmp <> MainFile And Left(tmp, 1) <> "~" Then
          k = k + 1
          ReDim Preserve Res(1 To k)
          Res(k) = tmp
        End If
      End If
    Next
  End With
  GetFileList = Res
  Set fso = Nothing: Set ObjFile = Nothing
End Function
 

File đính kèm

Upvote 0
Em cảm ơn Anh nhiều ạ. Hay quá anh ạ. Em copy File vào được rồi ạ. Nhìn nó phức tạp thật Anh, em sẽ mò để hiểu nó chạy thế nào ạ. Cảm ơn anh nhiều ạ. Nếu có bạn nào còn cách khác thì cũng giúp em và mọi người cùng câu hỏi có thể tham khảo thêm ạ !!!
 
Upvote 0
HieuCD đã viết:
Các file cùng thư mục
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), cn As Object
  Dim iPath As String, sqlStr As String
  Dim i As Long, j As Byte
  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr), 0 To 7)
  sqlStr = "select f1 from [G023311$D18:D24]"
  Set cn = CreateObject("ADODB.Connection")
  For i = LBound(fileArr) To UBound(fileArr)
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(i) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
    For j = LBound(sArr, 2) To UBound(sArr, 2)
      Res(i, j + 1) = sArr(0, j)
    Next j
    Res(i, 0) = Split(fileArr(i), "-")(1)
    cn.Close
  Next i
  Range("C18:J18").Resize(i - 1) = Res
  Set cn = Nothing
End Sub

Function GetFileList(ByVal StrFolder As String, Optional MainFile As String = "")
  Dim fso As Object, ObjFile As Object
  Dim Res(), k As Long, tmp As String
  Set fso = CreateObject("Scripting.FileSystemObject")
  With fso.GetFolder(StrFolder)
    For Each ObjFile In .Files
      If fso.GetExtensionName(ObjFile) Like "xls*" Then
        tmp = ObjFile.Name
        If tmp <> MainFile And Left(tmp, 1) <> "~" Then
          k = k + 1
          ReDim Preserve Res(1 To k)
          Res(k) = tmp
        End If
      End If
    Next
  End With
  GetFileList = Res
  Set fso = Nothing: Set ObjFile = Nothing
End Function
Nhấp chuột vào đây để mở rộng...


ANh ơi em xem code anh cho em hỏi chút được không ạ.
+ Nếu các File của em sheet có dữ liệu không đặt tên là G023311 mà theo nhiều tên khác nhau thì đoạn code đó như thế nào ạ.
+ Đọc Code e không hiểu đoạn nào để nó lấy cái ngày ở tên File ạ (20181002) ?

Em học lỏm mò cho một số công việc nên chỉ muốn hiểu hoạt động của Code mong anh chỉ dùm ạ. Thanks anh ạ.
 
Upvote 0
hoahuongduong1986 đã viết:
ANh ơi em xem code anh cho em hỏi chút được không ạ.
+ Nếu các File của em sheet có dữ liệu không đặt tên là G023311 mà theo nhiều tên khác nhau thì đoạn code đó như thế nào ạ.
+ Đọc Code e không hiểu đoạn nào để nó lấy cái ngày ở tên File ạ (20181002) ?

Em học lỏm mò cho một số công việc nên chỉ muốn hiểu hoạt động của Code mong anh chỉ dùm ạ. Cảm ơn anh ạ.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), S, cn As Object, Wb As Workbook
  Dim iPath As String, sqlStr As String
  Dim i As Long, j As Byte
  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr), 0 To 7)
  sqlStr = "select f1 from [G023311$D18:D24]"
  Set cn = CreateObject("ADODB.Connection")
  Application.ScreenUpdating = False
 
  For i = LBound(fileArr) To UBound(fileArr)
    If InStr(1, fileArr(i), "-") Then Res(i, 0) = Split(fileArr(i), "-")(1) 'Nam thang ngay
    On Error Resume Next
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(i) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
    cn.Close
    If Err.Number = 0 Then
      For j = LBound(sArr, 2) To UBound(sArr, 2)
        Res(i, j + 1) = sArr(0, j)
      Next j
    Else
      On Error GoTo 0
      Set Wb = Workbooks.Open(iPath & "\" & fileArr(i))
      sArr = Range("D18:D24").Value
      For j = 1 To UBound(sArr)
        Res(i, j) = sArr(j, 1)
      Next j
      Wb.Close False
    End If
  Next i
  Range("C18:J18").Resize(i - 1) = Res
  Set cn = Nothing
  Application.ScreenUpdating = True
End Sub

Function GetFileList(ByVal StrFolder As String, Optional MainFile As String = "")
  Dim Fso As Object, ObjFile As Object
  Dim Res(), k As Long, tmp As String
  Set Fso = CreateObject("Scripting.FileSystemObject")
  With Fso.GetFolder(StrFolder)
    For Each ObjFile In .Files
      If Fso.GetExtensionName(ObjFile) Like "xls*" Then
        tmp = ObjFile.Name
        If tmp <> MainFile And Left(tmp, 1) <> "~" Then
          k = k + 1
          ReDim Preserve Res(1 To k)
          Res(k) = tmp
        End If
      End If
    Next
  End With
  GetFileList = Res
  Set Fso = Nothing: Set ObjFile = Nothing
End Function
 
Upvote 0
HieuCD đã viết:
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), S, cn As Object, Wb As Workbook
  Dim iPath As String, sqlStr As String
  Dim i As Long, j As Byte
  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr), 0 To 7)
  sqlStr = "select f1 from [G023311$D18:D24]"
  Set cn = CreateObject("ADODB.Connection")
  Application.ScreenUpdating = False

  For i = LBound(fileArr) To UBound(fileArr)
    If InStr(1, fileArr(i), "-") Then Res(i, 0) = Split(fileArr(i), "-")(1) 'Nam thang ngay
    On Error Resume Next
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(i) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
    cn.Close
    If Err.Number = 0 Then
      For j = LBound(sArr, 2) To UBound(sArr, 2)
        Res(i, j + 1) = sArr(0, j)
      Next j
    Else
      On Error GoTo 0
      Set Wb = Workbooks.Open(iPath & "\" & fileArr(i))
      sArr = Range("D18:D24").Value
      For j = 1 To UBound(sArr)
        Res(i, j) = sArr(j, 1)
      Next j
      Wb.Close False
    End If
  Next i
  Range("C18:J18").Resize(i - 1) = Res
  Set cn = Nothing
  Application.ScreenUpdating = True
End Sub

Function GetFileList(ByVal StrFolder As String, Optional MainFile As String = "")
  Dim Fso As Object, ObjFile As Object
  Dim Res(), k As Long, tmp As String
  Set Fso = CreateObject("Scripting.FileSystemObject")
  With Fso.GetFolder(StrFolder)
    For Each ObjFile In .Files
      If Fso.GetExtensionName(ObjFile) Like "xls*" Then
        tmp = ObjFile.Name
        If tmp <> MainFile And Left(tmp, 1) <> "~" Then
          k = k + 1
          ReDim Preserve Res(1 To k)
          Res(k) = tmp
        End If
      End If
    Next
  End With
  GetFileList = Res
  Set Fso = Nothing: Set ObjFile = Nothing
End Function
Nhấp chuột vào đây để mở rộng...
Em cảm ơn Anh nhiều ạ ! Code rất hay ạ !!!
 
Upvote 0
hoahuongduong1986 đã viết:
Em cảm ơn Anh nhiều ạ ! Code rất hay ạ !!!
Nhấp chuột vào đây để mở rộng...
hoahuongduong1986 đã viết:
Em cảm ơn Anh nhiều ạ ! Code rất hay ạ !!!
Nhấp chuột vào đây để mở rộng...
HieuCD đã viết:
Các file cùng thư mục
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), cn As Object
  Dim iPath As String, sqlStr As String
  Dim i As Long, j As Byte
  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr), 0 To 7)
  sqlStr = "select f1 from [G023311$D18:D24]"
  Set cn = CreateObject("ADODB.Connection")
  For i = LBound(fileArr) To UBound(fileArr)
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(i) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
    For j = LBound(sArr, 2) To UBound(sArr, 2)
      Res(i, j + 1) = sArr(0, j)
    Next j
    Res(i, 0) = Split(fileArr(i), "-")(1)
    cn.Close
  Next i
  Range("C18:J18").Resize(i - 1) = Res
  Set cn = Nothing
End Sub

Function GetFileList(ByVal StrFolder As String, Optional MainFile As String = "")
  Dim fso As Object, ObjFile As Object
  Dim Res(), k As Long, tmp As String
  Set fso = CreateObject("Scripting.FileSystemObject")
  With fso.GetFolder(StrFolder)
    For Each ObjFile In .Files
      If fso.GetExtensionName(ObjFile) Like "xls*" Then
        tmp = ObjFile.Name
        If tmp <> MainFile And Left(tmp, 1) <> "~" Then
          k = k + 1
          ReDim Preserve Res(1 To k)
          Res(k) = tmp
        End If
      End If
    Next
  End With
  GetFileList = Res
  Set fso = Nothing: Set ObjFile = Nothing
End Function
Nhấp chuột vào đây để mở rộng...


Dear Anh,
Em lại làm phiền anh chút được không ạ. Hôm qua a trợ giúp em Copy được rồi nhưng nay làm việc lại có mẫu mới mà số liệu nó lại mà một mảng nhiều cột chứ không phải một cột như hôm qua ạ. Em có sửa code của anh nhưng do em chưa hiểu nên sửa nó không chạy được ạ. Anh có thể giúp em thêm cái Copy theo mảng được không ạ. Em gửi mẫu biểu anh giúp em với ạ. Em cảm ơn anh nhiều !
 

File đính kèm

Upvote 0
hoahuongduong1986 đã viết:
Dear Anh,
Em lại làm phiền anh chút được không ạ. Hôm qua a trợ giúp em Copy được rồi nhưng nay làm việc lại có mẫu mới mà số liệu nó lại mà một mảng nhiều cột chứ không phải một cột như hôm qua ạ. Em có sửa code của anh nhưng do em chưa hiểu nên sửa nó không chạy được ạ. Anh có thể giúp em thêm cái Copy theo mảng được không ạ. Em gửi mẫu biểu anh giúp em với ạ. Em cảm ơn anh nhiều !
Nhấp chuột vào đây để mở rộng...
Chỉnh Sub Main
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), cn As Object
  Dim iPath As String, sqlStr As String
  Dim n As Long, i As Long, j As Byte, Ngay
  Const dR As Byte = 11 'So dong file du lieu
 
  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr) * dR, 0 To 7)
 
  ' THay doi thong so vi tri dong cot ten
  sqlStr = "select * from [G023211$C19:I29]"
  Set cn = CreateObject("ADODB.Connection")
 
  For n = LBound(fileArr) To UBound(fileArr)
    ' so 3 là the hien lay tu dau - thu 3
    Ngay = Split(fileArr(n), "-")(3)
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(n) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
    
    For j = LBound(sArr, 2) To UBound(sArr, 2)
      k = k + 1 'Dòng ket qua
      Res(k, 0) = Ngay
      For i = LBound(sArr, 1) To UBound(sArr, 1)
        Res(k, i + 1) = sArr(i, j)
      Next i
    Next j
    cn.Close
  Next n
 
  ' Vi tri chon de copy past
  Range("C18:J18").Resize(k) = Res
  Set cn = Nothing
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh Sub Main
Mã: 
Sub Main()
  Dim Res(), fileArr(), sArr(), cn As Object
  Dim iPath As String, sqlStr As String
  Dim n As Long, i As Long, j As Byte, Ngay
  Const dR As Byte = 11 'So dong file du lieu

  iPath = ThisWorkbook.Path
  fileArr = GetFileList(iPath, ThisWorkbook.Name)
  ReDim Res(1 To UBound(fileArr) * dR, 0 To 7)

  ' THay doi thong so vi tri dong cot ten
  sqlStr = "select * from [G023211$C19:I29]"
  Set cn = CreateObject("ADODB.Connection")

  For n = LBound(fileArr) To UBound(fileArr)
    ' so 3 là the hien lay tu dau - thu 3
    Ngay = Split(fileArr(n), "-")(3)
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & "\" & fileArr(n) & ";Extended Properties=""Excel 12.0;HDR=No""")
    sArr = cn.Execute(sqlStr).GetRows
   
    For j = LBound(sArr, 2) To UBound(sArr, 2)
      k = k + 1 'Dòng ket qua
      Res(k, 0) = Ngay
      For i = LBound(sArr, 1) To UBound(sArr, 1)
        Res(k, i + 1) = sArr(i, j)
      Next i
    Next j
    cn.Close
  Next n

  ' Vi tri chon de copy past
  Range("C18:J18").Resize(k) = Res
  Set cn = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...


Vô cùng biết ơn anh và các anh chị trên diễn đàn về sự giúp đỡ ạ. Chúc Anh chị tháng mới nhiều may mắn và hạnh phúc ạ !!!!!
 
Upvote 0
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

H
Nhờ các bạn mở quá công thức của các sheet
Trả lời
1
Đọc
36
VetMini
V
K
  • Question Question
BÀI TOÁN TÌM GIÁ USD VÀ TÌM LƯỢNG KG - NHỜ ANH/CHỊ GIÚP ĐỠ
Trả lời
0
Đọc
12
khuongnguyencm69
K
S
Lỗi Path/File access error:'.\VBFB.tmp'
Trả lời
10
Đọc
4K
dhtq159
D
N
Vẽ đường tròn bám theo 1 Polyline
Trả lời
4
Đọc
51
nguyenvanvien
N
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
10
Đọc
191
Mewwo98
Mewwo98
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
3
Đọc
133
trung_bhxh
T
huongmuine
Điền số thứ tự theo nhóm có điều kiện
Trả lời
0
Đọc
10
huongmuine
huongmuine
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
311
Đọc
23K
kunkoi9390
K
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
4
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
OverAC
TPHCM - Gặp mặt đầu năm Ất Tỵ 18g ngày 8/2
    • Thích
    • Ngạc nhiên
Trả lời
1
Đọc
72
tungnguyen_kt
tungnguyen_kt
ptm0412
  • Question Question
Cách lấy link file excel nguồn cho Power query từ Onedrive, Google drive
    • Thích
    • Yêu thích
Trả lời
7
Đọc
3K
pxhieu1993
P
Y
Nhờ các anh chị xem giúp Hàm Sumproduct
Trả lời
0
Đọc
33
yoomi
Y
dinhnhat91
  • Question Question
VBA Lỗi runtime error 9 subscript out of range
Trả lời
4
Đọc
104
ongke0711
ongke0711
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
1
Đọc
559
PhanTuHuong
PhanTuHuong
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
0
Đọc
63
Việt Nguyễn 86
Việt Nguyễn 86
K
Mong giúp dữ liệu từ trang web sang excel
Trả lời
0
Đọc
59
khanhvinhdai1
K
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
3
Đọc
1K
trung_bhxh
T
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
52
Đọc
103K
khanhvinhdai1
K
Huyen9
Lỗi không mailings được.
Trả lời
3
Đọc
93
vanle33
vanle33
K
Có ai giúp mình lấy kết quả xổ số miền nam về file excel
Trả lời
0
Đọc
50
khanhvinhdai1
K
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