Find & Copy Sheet thoã mãn điều kiện từ nhiều Files qua File mới có tên User đưa vào. (1 người xem)

[Dang Nguyen Dac]

Em cần làm một macro có công dụng như hình. Khối màu cam là chương trình con. Mong các thầy giúp cho ạ! Em xin chân thành cảm ơn.

 

[befaint]

Chào Dang Nguyen Dac,

Hình thì đẹp đó nhưng chỉ để nhìn tham khảo thôi. Bạn muốn làm thì gửi file lên (file mà chứa sheet cần copy ấy, chỗ nào cần tham chiếu ...)
Thứ nữa, cách của bạn mà nhập hoài, nhập hoài mà không trúng cái sheet cần copy thì làm sao?
Có thể làm Form có danh sách tên các sheet cần copy rồi lựa chọn được hông?

 

[Dang Nguyen Dac]

Chào Dang Nguyen Dac,

Hình thì đẹp đó nhưng chỉ để nhìn tham khảo thôi. Bạn muốn làm thì gửi file lên (file mà chứa sheet cần copy ấy, chỗ nào cần tham chiếu ...)
Thứ nữa, cách của bạn mà nhập hoài, nhập hoài mà không trúng cái sheet cần copy thì làm sao?
Có thể làm Form có danh sách tên các sheet cần copy rồi lựa chọn được hông?

Chào befaint!

Mình có một thư mục tầm 30-40 files, mỗi file có tầm 20-40 sheets số lượng k giống nhau, dung lượng từ 20-50MB nên việc gửi file là vô khả thi. Các sheet trong từng file có tên giống nhau hoặc khác nhau phần nào đó. Mình là người quản lý và mình biết info mình cần tìm nằm ở sheet nào, có tên là gì nên sẽ k lo lắng việc đánh tên sai.

Mục đích của macro này là, khi mình cần tìm info nằm ở sheet "ABC" thì InputName = "ABC" và macro sẽ tự động copy sheet có cell C3 = "ABC" từ tất cả các files *.xls trong thư mục cho trước qua một file mới có tên là ABC.xls. Nghĩa là macro sẽ trích xuất tất cả sheet thoã mãn điều kiện Range("C3").Value = "ABC" (mỗi file 1 sheet) gộp chung vào một file mới tên là ABC.xls

Thuật toán trong hình cover gần hết các trường hợp rùi á bạn. Cảm ơn bạn đã trả lời!

Thanks,
Dang

 

[Dang Nguyen Dac]

Sub CopySheets()

Dim TargetSheet As Variant
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim TempSheetName As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'---INPUT NAME--------------------------------------------------------------------------------
On Error Resume Next
TargetSheet = InputBox("Ban muon copy sheet nao?")
On Error GoTo 0
If TargetSheet = vbNullString Then MsgBox "Canceled"

'---CREATE INPUTNAME.XLS----------------------------------------------------------------------
Set Newbook = Workbooks.Add
With Newbook
    .Title = TargetSheet
    .SaveAs Filename:="C:\Users\dang.nguyendac\Desktop\" & TargetSheet & ".xls"
End With

'---LOOP & COPY SHEETS TO INPUTNAME.XLS-------------------------------------------------------
Path = "C:\Users\dang.nguyendac\Desktop\TEST\"
Filename = Dir(Path & "*.xls")
Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
        TempSheetName = Sheets("Intro").Range("C2").Value
        TempSheetName = Replace(Replace(TempSheetName, ":", ""), ".", "")
        '
        '{NEED HELP HERE}
        '
        ActiveSheet.Name = Left(TempSheetName, 31)
    wbk.Close True
    Filename = Dir
Loop

'---SAVE---------------------------------------------------------------------------------------
Workbooks(TargetSheet).Activate
'Worksheets("Sheet1").Delete
For Each Name In ActiveWorkbook.Names
    Name.Delete
Next Name
ActiveWorkbook.Save

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

{NEED HELP HERE}
Loop trên các sheet của file
Nếu Range("C3").Value = "ABC" thì copy Sheet đó qua file TargetSheet.xls, Exit Loop, tới file tiếp theo.

Các thầy code giúp e với ạ. Trình e chỉ tới ngang đây.