Nhờ giúp đỡ Code để lấy các dữ liệu từ nhiều file nguồn

[Thóc Sama]

Xin chào Anh, Chị
Các File nguồn(PO đặt hàng) của em có chung format . Hàng tháng bên bộ phận thu mua nguyên liệu phải lập-chỉnh sửa-phát hành nhiều PO.
Em muốn làm một file [Cap nhat DL]để tổng hợp lại các nội dung như phía dưới. Tuy nhiên để mở từng file nguồn copy và paste dữ liệu sẽ mất thời gian
Nhờ Anh, Chị Code dùm em theo nhu cầu mô tả như trong hình và file đính kèm nhé
Cảm ơn Anh, Chị nhiều!

 

[NHG]

Dạ
Tạm thời thế bác nhỉ!

Em thử Map Network Drive cái đường dẫn xem, và trong đường dẫn không sử dụng dấu tiếng việt, rồi thử chạy code của bạn Maika xem, vì code ghép file kỵ nhất đường dẫn, tên file có dấu tiếng việt

 

[Thóc Sama]

Em thử Map Network Drive cái đường dẫn xem, và trong đường dẫn không sử dụng dấu tiếng việt, rồi thử chạy code của bạn Maika xem, vì code ghép file kỵ nhất đường dẫn, tên file có dấu tiếng việt

Dạ quả thực thế đó bác
đường dẫn của em có dấu tiếng việt, dấu cách, và cả tiếng Nhật nữa
Khoai thật!

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

mở bằng tay thì excel có mở được file đó không?

Em chưa hiểu ý bác lắm!

 

[HUONGHCKT]

Bạn để tất cả file nguồn vào 1 folder (Sửa đường dẫn lại và folder không được chứa các file khác, kể cả file CapNhat) rồi chạy code

Tôi cũng rất quan tâm đến vấn đề này. Xin hỏi Các Anh chị em là: Nếu các file nguồn kia số lượng cũng tương đối nhiều ( gần 200 file như vậy) và đều có dạng Nguon x.slxs nằm dải rác trong cùng một ổ đĩa. Thì làm thế nào để lấy số liệu ở các file đó mà không cần phải gom chung về cùng 1 folder có được không? Nếu phải gom chung thì code thế nào?
Nếu anh chị nào biết có thể cho tôi xin code của cả hai trường hợp trên? Xin trân trọng cảm ơn!
Code tôi đã làm nhưng báo lỗi.

Sub LayBosungDoten()

Dim fso As Object
Dim Ws As Worksheet
Dim tenShMoi As String
Dim WbNguon As Workbook

Set fso = CreateObject("Scripting.FileSystemObject")
For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\").Files
    If file.Name Like "* PCGD" & "*.xls" Then
        Set wbMoi = Workbooks.Open(file.Name)     '======Bi lôi dong này "không tim thây, có thê đa đôi ten, di chuyên hoac đa xoa"
        For Each Ws In WbNguon.Sheets
            If Ws.Name = "XXXXXXX....." Then
               '....lay dư liêu vê Sh tông hop
               ' Bô sung dư liêu cho Ws
               ' đôi tên sheet
               
               ''tenShMoi = "PCGD" & t & ".xlsx"
            End If
        Next Ws
    End If
Next file
Set fso = Nothing
End Sub

 

[HieuCD]

Tôi cũng rất quan tâm đến vấn đề này. Xin hỏi Các Anh chị em là: Nếu các file nguồn kia số lượng cũng tương đối nhiều ( gần 200 file như vậy) và đều có dạng Nguon x.slxs nằm dải rác trong cùng một ổ đĩa. Thì làm thế nào để lấy số liệu ở các file đó mà không cần phải gom chung về cùng 1 folder có được không? Nếu phải gom chung thì code thế nào?
Nếu anh chị nào biết có thể cho tôi xin code của cả hai trường hợp trên? Xin trân trọng cảm ơn!
Code tôi đã làm nhưng báo lỗi.

Sub LayBosungDoten()

Dim fso As Object
Dim Ws As Worksheet
Dim tenShMoi As String
Dim WbNguon As Workbook

Set fso = CreateObject("Scripting.FileSystemObject")
For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\").Files
    If file.Name Like "* PCGD" & "*.xls" Then
        Set wbMoi = Workbooks.Open(file.Name)     '======Bi lôi dong này "không tim thây, có thê đa đôi ten, di chuyên hoac đa xoa"
        For Each Ws In WbNguon.Sheets
            If Ws.Name = "XXXXXXX....." Then
               '....lay dư liêu vê Sh tông hop
               ' Bô sung dư liêu cho Ws
               ' đôi tên sheet
              
               ''tenShMoi = "PCGD" & t & ".xlsx"
            End If
        Next Ws
    End If
Next file
Set fso = Nothing
End Sub

Chỉnh tí xíu
Set wbMoi = Workbooks.Open(file)

 

[HUONGHCKT]

Chỉnh tí xíu
Set wbMoi = Workbooks.Open(file)

Cảm ơn Anh. Nhờ sự chỉ giáo của Anh mà tôi đã làm được phần tìm kiếm các file nằm dải rác. Còn phần Gom các file có chung đặc điểm (VD: "PCGD...slsx) vào một folderthif vẫn chưa mày mò ra được. Nếu có thể mong Anh chị em chỉ giúp.
Trân trọng.

 

[Thóc Sama]

Em chào Anh, Chị
Rất cảm ơn mọi người đã nhiệt tình hỗ trợ ạ
Qua Topic này, em đã nhận được kết quả như mong muốn của một "người lạ" ạ.
Em xin chia sẽ Code để mọi người tham khảo nhé!

Option Explicit
Option Private Module

Public Sub Load_File_Data()
Dim FOb As Object, fso As Object, Item, Path As String, Rw As Long, CotMax, lR As Long
Dim NgayN, MaN, TenN, sArr, dArr, I As Long, K As Long, J As Long, Home
Dim WsM As Worksheet, Ws As Worksheet, Wb As Workbook, Stt

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

On Error Resume Next

CotMax = 11

Set WsM = ActiveSheet
WsM.ShowAllData

Set fso = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True 'False
.Filters.Add "Microsoft Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban chua chon File", vbInformation, "???"
Exit Sub
End If

'Set DicR = CreateObject("Scripting.Dictionary")

ReDim dArr(1 To 100000, 1 To CotMax)

For Each Item In .SelectedItems
If Left(Item, 1) <> "~" Then
Set Wb = Workbooks.Open(Item)
'For Each Ws In Wb.Worksheets
Set Ws = Wb.Sheets(1)
Ws.ShowAllData
lR = Ws.Range("B" & Rows.Count).End(3).Row
sArr = Ws.Range("B22:B" & lR).Resize(, 8).Value
Stt = Stt + 1
For I = 1 To UBound(sArr)
If Len(sArr(I, 1)) Then
K = K + 1
dArr(K, 1) = Stt
dArr(K, 2) = Trim(Mid(Ws.Range("I1").Value, 6, 200))
dArr(K, 3) = CDate(Mid(Ws.Range("I2").Value, 7, 10))
dArr(K, 4) = Mid(Ws.Range("A7").Value, 5, 500)
dArr(K, 5) = sArr(I, 1)
dArr(K, 6) = sArr(I, 2)
dArr(K, 7) = sArr(I, 3)
dArr(K, 8) = Val(sArr(I, 4))
dArr(K, 9) = Val(sArr(I, 5))
dArr(K, 10) = Val(sArr(I, 6))
dArr(K, 11) = sArr(I, 7)
End If
Next
'Next

Wb.Close
End If
Next

End With
lR = WsM.Range("B" & Rows.Count).End(3).Row
If lR > 3 Then
With WsM
With .Range("B4:B" & lR).Resize(, CotMax)
.ClearContents
.Borders.LineStyle = 0
End With
End With
End If

If K Then
With WsM
.Range("B4").Resize(K, CotMax).Value = dArr
.Range("B3").Resize(K + 1, CotMax).Borders.Color = RGB(192, 192, 192)
End With
End If

Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[Excel my love_1]

Em chào Anh, Chị
Rất cảm ơn mọi người đã nhiệt tình hỗ trợ ạ
Qua Topic này, em đã nhận được kết quả như mong muốn của một "người lạ" ạ.
Em xin chia sẽ Code để mọi người tham khảo nhé!

Option Explicit
Option Private Module

Public Sub Load_File_Data()
Dim FOb As Object, fso As Object, Item, Path As String, Rw As Long, CotMax, lR As Long
Dim NgayN, MaN, TenN, sArr, dArr, I As Long, K As Long, J As Long, Home
Dim WsM As Worksheet, Ws As Worksheet, Wb As Workbook, Stt

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

On Error Resume Next

CotMax = 11

Set WsM = ActiveSheet
WsM.ShowAllData

Set fso = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True 'False
.Filters.Add "Microsoft Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban chua chon File", vbInformation, "???"
Exit Sub
End If

'Set DicR = CreateObject("Scripting.Dictionary")

ReDim dArr(1 To 100000, 1 To CotMax)

For Each Item In .SelectedItems
If Left(Item, 1) <> "~" Then
Set Wb = Workbooks.Open(Item)
'For Each Ws In Wb.Worksheets
Set Ws = Wb.Sheets(1)
Ws.ShowAllData
lR = Ws.Range("B" & Rows.Count).End(3).Row
sArr = Ws.Range("B22:B" & lR).Resize(, 8).Value
Stt = Stt + 1
For I = 1 To UBound(sArr)
If Len(sArr(I, 1)) Then
K = K + 1
dArr(K, 1) = Stt
dArr(K, 2) = Trim(Mid(Ws.Range("I1").Value, 6, 200))
dArr(K, 3) = CDate(Mid(Ws.Range("I2").Value, 7, 10))
dArr(K, 4) = Mid(Ws.Range("A7").Value, 5, 500)
dArr(K, 5) = sArr(I, 1)
dArr(K, 6) = sArr(I, 2)
dArr(K, 7) = sArr(I, 3)
dArr(K, 8) = Val(sArr(I, 4))
dArr(K, 9) = Val(sArr(I, 5))
dArr(K, 10) = Val(sArr(I, 6))
dArr(K, 11) = sArr(I, 7)
End If
Next
'Next

Wb.Close
End If
Next

End With
lR = WsM.Range("B" & Rows.Count).End(3).Row
If lR > 3 Then
With WsM
With .Range("B4:B" & lR).Resize(, CotMax)
.ClearContents
.Borders.LineStyle = 0
End With
End With
End If

If K Then
With WsM
.Range("B4").Resize(K, CotMax).Value = dArr
.Range("B3").Resize(K + 1, CotMax).Borders.Color = RGB(192, 192, 192)
End With
End If

Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Cảm ơn bạn đã chia sẻ code, cho mình hỏi thêm chút là code này đặt ở trong file tổng hợp (file đích) đúng không bạn,
khi code hoạt động thì mình phải chọn đến folder nơi chứa các file có dữ liệu (file nguồn) à
bạn có thể mô tả qua cách hoạt động code này được không bạn?
Rất cảm ơn bạn

 

[Thóc Sama]

Cảm ơn bạn đã chia sẻ code, cho mình hỏi thêm chút là code này đặt ở trong file tổng hợp (file đích) đúng không bạn,
khi code hoạt động thì mình phải chọn đến folder nơi chứa các file có dữ liệu (file nguồn) à
bạn có thể mô tả qua cách hoạt động code này được không bạn?
Rất cảm ơn bạn

Vâng
File tổng hợp chứa code
khi run code thì sẽ hiện hộp thoại để mình chỉ đến file nguồn (các PO)
1. không chọn file nào thì hủy lệnh (msg chưa chọn file)
2. Nếu chọn file nguồn thì thực thi lệnh như yêu cầu #1
Tổng quan là thế, phần chi tiết và hướng viết code của tác giả bạn xem #26 nhé!
Bạn cũng có thể down file về ở #1 + Code ở #26 rồi nghiên cứu thêm ha.
Thân!

 

[Excel my love_1]

Vâng
File tổng hợp chứa code
khi run code thì sẽ hiện hộp thoại để mình chỉ đến file nguồn (các PO)
1. không chọn file nào thì hủy lệnh (msg chưa chọn file)
2. Nếu chọn file nguồn thì thực thi lệnh như yêu cầu #1
Tổng quan là thế, phần chi tiết và hướng viết code của tác giả bạn xem #26 nhé!
Bạn cũng có thể down file về ở #1 + Code ở #26 rồi nghiên cứu thêm ha.
Thân!

Cảm ơn bạn đã hướng dẫn tận tình, file rất hữu ích. Vậy là quá đủ cho nhu cầu rồi
Nhưng Nếu sau này có điều kiện bạn nâng cấp được lên thành, code trỏ đến folder lấy toàn bộ dữ liệu các file nằm trong folder đưa dữ liệu về file đích