Xin trợ giúp VBA lấy dữ liệu từ File theo giá trị Range cho trước

[ngoctuyen1995]

Thân chào cả nhà GPEX,
Mong cả nhà giúp em một việc ạ,
Hiện tại em có các File Data bao gồm khoản 5 sheet (file đính kèm e làm demo 2 sheet thôi ạ) và 01 File Temp_Tool (tương ứng tên sheet với các sheet bên data) là Template chuẩn.
Em muốn dùng VBA dựa vào File Temp_Tool tương ứng với dòng 5 là điều kiện để lấy data bên File Data tương ứng với các Sheet.
Ví dụ: Range A6 (File temp_Tool) = Range B5 (File Data điều kiện ở dòng 5) ==> Store 01 (tương tự chạy hết dòng 5)
Mong cả nhà giúp đỡ,
Em chân thành cảm ơn ạ.

 

[HieuCD]

Thân chào cả nhà GPEX,
Mong cả nhà giúp em một việc ạ,
Hiện tại em có các File Data bao gồm khoản 5 sheet (file đính kèm e làm demo 2 sheet thôi ạ) và 01 File Temp_Tool (tương ứng tên sheet với các sheet bên data) là Template chuẩn.
Em muốn dùng VBA dựa vào File Temp_Tool tương ứng với dòng 5 là điều kiện để lấy data bên File Data tương ứng với các Sheet.
Ví dụ: Range A6 (File temp_Tool) = Range B5 (File Data điều kiện ở dòng 5) ==> Store 01 (tương tự chạy hết dòng 5)
Mong cả nhà giúp đỡ,
Em chân thành cảm ơn ạ.

Chép tất cả file data vào chung 1 thư mục, chạy code XYZ, chọn thư mục chứa file data

Option Compare Text

Sub XYZ()
  Dim cn As Object, objFSO As Object, objFiles As Object, oFile As Object
  Dim aCol, Arr, Res()
  Dim FolderName$, FileName$, k&, n&, shCount&
  Dim j As Long

  With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count = 0 Then MsgBox ("Phai Chon Thu Muc!"): Exit Sub
    FolderName = .SelectedItems(1)
  End With
 
  On Error Resume Next
  Application.ScreenUpdating = False
  If FolderName <> Empty Then
    shCount = Sheets.Count
    aCol = Array("", 1, 0, 2, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
    ReDim Arr(1 To 100, 1 To 13) 'Toi da 100 file Data
    ReDim Res(1 To 2, 1 To shCount)
    For n = 1 To shCount
      Res(1, n) = Arr
      Res(2, n) = Sheets(n).Name
    Next n
    
    Set cn = CreateObject("ADODB.Connection")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFSO.GetFolder(FolderName).Files
    For Each oFile In objFiles
      FileName = oFile.Path
      If Right(FileName, 5) = ".xlsx" Then
        k = k + 1
        Call ADO_LayDL(Res, aCol, k, cn, FileName)
      End If
    Next oFile
    If k Then
      For n = 1 To shCount
        With Sheets(n)
          .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 13) = Res(1, n)
        End With
      Next n
    Else
      MsgBox ("Khong co File du lieu")
    End If
  End If
  Set cn = Nothing
  Application.ScreenUpdating = True
End Sub

Private Sub ADO_LayDL(ByRef Res, ByRef aCol, ByRef k, ByRef cn, ByRef FileName)
  Dim sArr, n&
 
  cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=No""")
  For n = 1 To UBound(Res, 2)
    sArr = cn.Execute("select f1 from [" & Res(2, n) & "$B1:B19] where f1 is not null").GetRows
    If TypeName(sArr) = "Variant()" Then
      For j = 1 To UBound(aCol)
        Res(1, n)(k, j) = sArr(0, aCol(j))
      Next j
    End If
  Next n
  cn.Close
End Sub