Giúp em lấy dữ liệu từ các file nằm ở các folder khác nhau theo đường dẫn

[vonguyen3745]

Em có các file nằm ở các thư mục khác nhau, muốn lấy dữ liệu về 1 file tổng hợp. Các file này có sẵn đường dẫn, sheets cần lấy và vùng cần lấy dữ liệu. Thanks

 

[vonguyen3745]

Các file đều có cấu trúc kiểu thế này:
D:\TIEU_HOC\SynologyDrive\c1_anha\NAMHOC_2021-2022\1.TCCB\BIEU_MAU_EXCEL\DOINGU_TH_THANG7.xlsx

 

[Hoàng Nhật Phương]

Các file đều có cấu trúc kiểu thế này:
D:\TIEU_HOC\SynologyDrive\c1_anha\NAMHOC_2021-2022\1.TCCB\BIEU_MAU_EXCEL\DOINGU_TH_THANG7.xlsx

Chào Bạn, qua tìm hiểu với khả năng hiểu của OT thì nguyên nhân do xử lý đoạn này:


Vì vậy mà công thức dài quá gấp 2 lần so với ban đầu, OT có tham khảo ở đây thấy họ có thông tin:


OT không hiểu tiếng Tây lắm, đoán có thể do đường dẫn dài (quá 255 ký tự) đã đề cập ở bài 18,do vậy với đường dẫn dài thì cách của OT không khả thi, Bạn sử dụng code ở bài 2 nhé.

 

[vonguyen3745]

Ở Bài 2 mình không biết chỗ chỉnh để nó bắt đầu dán dữ liệu ở dòng A4, bạn biết chỉnh giúp mình với.

 

[Quang_Hải]

Ở Bài 2 mình không biết chỗ chỉnh để nó bắt đầu dán dữ liệu ở dòng A4, bạn biết chỉnh giúp mình với.

Code của bài 2 là sẽ dán dữ liệu nối đuôi nhau. Nếu bạn muốn gán dữ liệu ở dòng 4 thì dòng tiêu đề phải là dòng số 3 nhé. Lưu ý là trước khi chạy code phải xóa hết dữ liệu cũ, vì code sẽ dán nối đuôi so với dữ liệu đang có

 

[Hoàng Nhật Phương]

Code của bài 2 là sẽ dán dữ liệu nối đuôi nhau. Nếu bạn muốn gán dữ liệu ở dòng 4 thì dòng tiêu đề phải là dòng số 3 nhé. Lưu ý là trước khi chạy code phải xóa hết dữ liệu cũ, vì code sẽ dán nối đuôi so với dữ liệu đang có

Chào anh Quang Hải, em thấy bài này dùng "FileSystemObject" để kiểm tra sự phù hợp của file có tồn tại hay không là khả thi nhất Anh nhỉ?

 

[Quang_Hải]

Chào anh Quang Hải, em thấy bài này dùng "FileSystemObject" để kiểm tra sự phù hợp của file có tồn tại hay không là khả thi nhất Anh nhỉ?

Mấy cái này thuộc dạng cơ bản. Chẳng qua đang chán vì dịch covid nên chả buồn viết code. Đang bận cuốc đất trồng rau. Bài này trong khả năng của bạn mà.

 

[Hoàng Nhật Phương]

Mấy cái này thuộc dạng cơ bản. Chẳng qua đang chán vì dịch covid nên chả buồn viết code. Đang bận cuốc đất trồng rau. Bài này trong khả năng của bạn mà.

Hic Anh còn có đất để cuốc , chỗ em hết rồi chỉ có mấy mét vuông để ăn nằm thôi Anh hiện tại đi làm về đến nhà là nằm và thở thôi anh ạ,chán hơn con gián.

 

[vonguyen3745]

Mấy cái này thuộc dạng cơ bản. Chẳng qua đang chán vì dịch covid nên chả buồn viết code. Đang bận cuốc đất trồng rau. Bài này trong khả năng của bạn mà.

Thế em với bác có thể đổi chỗ cho nhau được mà, bác viết code để em cuốc đất cho, em bên chân tay nên việc cuốc đất là việc nhỏ thôi.

 

[Maika8008]

- Ý em là ở sheet đích, nếu có sẵn dữ liệu rồi thì code nó không copy đè lên dữ liệu ở đó.
- Em muốn chỉnh ô đầu tiên dán dữ liệu thì chỉnh thế nào bác, nó mặc định là ô A2, nhiều khi phần tiêu đề nó có 3-4 dòng thì lại không chạy được

- Code luôn chép đè lên dữ liệu cũ tại sheet đích. Do đó, muốn khỏi lộn xộn dữ liệu mới và cũ còn sót lại thì phải xóa hết dữ liệu cũ đi rồi chép dữ liệu mới.
=> Thêm dòng này vào đầu code để xóa dữ liệu cũ:
Sheet2.Range("A4:Z" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).ClearContents
- Để chỉnh dòng đầu tiên dán dữ liệu thì thay dòng:
fRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
bằng:
If i = 1 Then
fRow = 4
Else
fRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
End If
(fRow = 4 là dòng đầu, muốn sửa thì sửa con số này và sửa luôn Sheet2.Range("A4:Z" bên trên)

 

[vonguyen3745]

thanks, sao em cứ đổi tên Sheet2 thành sheets khác nó lại không chạy nhỉ, em đã đổi tên cả trên excel và code mà nó toàn báo lỗi.

 

[HieuCD]

thanks, sao em cứ đổi tên Sheet2 thành sheets khác nó lại không chạy nhỉ, em đã đổi tên cả trên excel và code mà nó toàn báo lỗi.
View attachment 262771
View attachment 262773

Chỉnh tí

Sub ABC()
  Dim sArr(), cn As Object, i&, fRow&
  With Sheets("Sheet1")
    sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
  End With
 
  Set cn = CreateObject("ADODB.Connection")
  On Error Resume Next
  With Sheets("DanhSach")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:Z" & i).ClearContents 'Xoa ket qua cu
    For i = 1 To UBound(sArr)
      fRow = .Range("B" & Rows.Count).End(xlUp).Row + 1
      If fRow < 4 Then fRow = 4
      cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sArr(i, 1) & ";Extended Properties=""Excel 12.0;HDR=No"";"
      .Range("B" & fRow).CopyFromRecordset cn.Execute("select * from [" & sArr(i, 2) & "$" & sArr(i, 3) & "] where f1 is not null")
      cn.Close
    Next i
  End With
  Set cn = Nothing
End Sub

 

[quick87]

Một cách làm khác, bạn tham khảo thêm:

Option Explicit

Dim sFile  As String
Sub DataLink(ByRef cell_ As Range, ByVal sLink As String, ByVal sFileName As String)
    On Error GoTo Err_
    cell_.FormulaArray = sLink: cell_.Value = cell_.Value
    If Len(sFile) = 0 Then sFile = sFileName Else sFile = sFile & vbNewLine & sFileName
Err_:
End Sub

Sub RunMe()

    Dim sheet As Worksheet, start_cell As Range, cell_ As Range, str As String, tmp
    Dim sFolder As String, sFileName As String, sShName As String, sRange As String
    Dim sLink As String
  
    Application.ScreenUpdating = False
    Set sheet = Sheet2: sheet.Cells.ClearContents
    Set start_cell = Sheet1.Range("A2")
    sFile = Empty
    Do Until start_cell.Value = ""
        str = start_cell.Value
        tmp = Split(str, "\")
        sFileName = tmp(UBound(tmp))
        sFolder = Mid(str, 1, Len(str) - Len(sFileName) - 1)
        If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
            sShName = start_cell.Offset(, 1).Value
            sRange = start_cell.Offset(, 2).Value
            Set cell_ = sheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
            Set cell_ = cell_.Resize(sheet.Range(sRange).Rows.Count, sheet.Range(sRange).Columns.Count)
            sLink = "='" & sFolder & "\[" & sFileName & "]" & sShName & "'!" & sRange & ""
            DataLink cell_, sLink, sFileName
        End If
        Set start_cell = start_cell.Offset(1)
    Loop
  
    Application.ScreenUpdating = True
    sheet.Activate
  
    If Len(sFile) > 0 Then
        sFile = "File link OK:" & vbNewLine & sFile
    End If
  
    MsgBox "Kêt thúc " & vbNewLine & sFile, vbOKOnly + vbInformation
  
End Sub

Nhờ mọi người viết thêm giúp tạo thêm 02 cột: tên file, tên sheet với code bài này. Xin cảm ơn!