Copy dữ liệu theo tên file, tên sheet

[AnhNQT]

Xin chào các bác ạ, nhờ các bác hỗ trợ giúp em VBA hoặc Power Query với ạ.
Em có 1 thư mục chứa nhiều file excel, em cần lấy dữ liệu được vào file mới kia (CopyData) khi mình điền tên file và tên sheet (như file ví dụ trong tệp đính kèm). Dữ liệu copy sang không cần đúng theo định dạng cũng được.
Cảm ơn các bác!

 

[HUONGHCKT]

Xin chào các bác ạ, nhờ các bác hỗ trợ giúp em VBA hoặc Power Query với ạ.
Em có 1 thư mục chứa nhiều file excel, em cần lấy dữ liệu được vào file mới kia (CopyData) khi mình điền tên file và tên sheet (như file ví dụ trong tệp đính kèm). Dữ liệu copy sang không cần đúng theo định dạng cũng được.
Cảm ơn các bác!

Nếu là chỉ lấy dữ liệu của 1 file (và chỉ lấy ở 1Sh chỉ định- Các file cần lấy đều được chứa trong Folder CopyData) thì dùng thử code này xem sao.

Option Explicit
Sub COPYDATA()
Dim Lr&
Dim WbMoi As Workbook, Ws As Worksheet
Dim TenSh As String, Tenfile As String
Dim file As Variant

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
Tenfile = Sheets("CopyDT").Range("A2")
TenSh = Sheets("CopyDT").Range("B2")

For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\CopyData").Files
    If file.Name Like Tenfile & ".xlsx" Then
       Set WbMoi = Workbooks.Open(file)
          For Each Ws In WbMoi.Sheets
            If Ws.Name = TenSh Then
                Ws.Select
                Lr = Ws.Range("H100000").End(xlUp).Row          
                 If Lr = 1 Then
                    MsgBox " File cân lây dư liêu rông-hay kiêm tra lai", vbInformation, "THÔNG BÁO"
                    Exit Sub
                Else
                 '   ThisWorkbook.Sheets("CopyDT").Range("D1:K" & Lr).ClearContents
                    Ws.Range("A1:K" & Lr).Copy ThisWorkbook.Sheets("CopyDT").Range("D1")
                End If
            End If
          Next Ws
        WbMoi.Close
    End If
Next file
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox " Đa hoàn thành lây dư liêu tư file " & Sheets("CopyDT").Range("A2"), vbInformation, "THÔNG BÁO"
End Sub

Hãy điều chỉnh lại đường dẫn cho phù hợp.
Nhấn nút LẤY DỮ LIỆU và kiểm tra kết quả.

 

[AnhNQT]

Nếu là chỉ lấy dữ liệu của 1 file (và chỉ lấy ở 1Sh chỉ định- Các file cần lấy đều được chứa trong Folder CopyData) thì dùng thử code này xem sao.

Option Explicit
Sub COPYDATA()
Dim Lr&
Dim WbMoi As Workbook, Ws As Worksheet
Dim TenSh As String, Tenfile As String
Dim file As Variant

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
Tenfile = Sheets("CopyDT").Range("A2")
TenSh = Sheets("CopyDT").Range("B2")

For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\CopyData").Files
    If file.Name Like Tenfile & ".xlsx" Then
       Set WbMoi = Workbooks.Open(file)
          For Each Ws In WbMoi.Sheets
            If Ws.Name = TenSh Then
                Ws.Select
                Lr = Ws.Range("H100000").End(xlUp).Row         
                 If Lr = 1 Then
                    MsgBox " File cân lây dư liêu rông-hay kiêm tra lai", vbInformation, "THÔNG BÁO"
                    Exit Sub
                Else
                 '   ThisWorkbook.Sheets("CopyDT").Range("D1:K" & Lr).ClearContents
                    Ws.Range("A1:K" & Lr).Copy ThisWorkbook.Sheets("CopyDT").Range("D1")
                End If
            End If
          Next Ws
        WbMoi.Close
    End If
Next file
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox " Đa hoàn thành lây dư liêu tư file " & Sheets("CopyDT").Range("A2"), vbInformation, "THÔNG BÁO"
End Sub

Hãy điều chỉnh lại đường dẫn cho phù hợp.
Nhấn nút LẤY DỮ LIỆU và kiểm tra kết quả.

Em cảm ơn bác nhiều, chúc bác sức khỏe!