new logic need to add to the code

[syed_iqbal]

Hi,

Pls go through the code in the attached file. the code in the file works on all employees in the "Master" Sheet. But, Code should be work on those employees who are "Working". those data only need to be extracted and saved in new workbook. Pls help.

Note: the code intention is, filter all the sheets based on employee name (in master sheet) and copied those filtered sheets data then pasted in new workbook and saved in new folder.

Thank you in advance

regards
iqbal

[JKwan]

give this a try

Sub Button1_Click()
    Dim sh As Worksheet, ws As Worksheet
    Dim LstRw As Long, Rng As Range, a As Range, c As Range
    Dim d As Range
    Dim wb As Workbook, bk As Workbook
    Set wb = ThisWorkbook
    MkDir ("C:\users\ajay\desktop\test_1\")
    With wb
        Set ws = .Sheets("Master")
    End With
    Application.ScreenUpdating = 0
    With ws
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range("A2:A" & LstRw)
        For Each a In Rng.Cells
            If a.Offset(0, 1) = "Working" Then
                Set bk = Workbooks.Add
                For Each sh In wb.Sheets
                    
                    If sh.Name <> "Master" And sh.Name <> "Emp Information" Then
                        With sh
                            
                            Set c = sh.Cells.Find(what:=a, lookat:=xlWhole)
                            If Not c Is Nothing Then
                                bk.Sheets.Add
                                ActiveSheet.Name = sh.Name
                                .Range("A1:S1").Copy Destination:=Range("A1")
                                c.EntireRow.Copy Destination:=Range("A2")
                                On Error Resume Next
                            End If
                        End With
                    End If
                Next sh
                Application.DisplayAlerts = 0
                For Each ws In ActiveWorkbook.Worksheets
                    If Application.CountA(ws.Cells) = 0 Then ws.Delete
                Next ws
                bk.SaveAs filename:="C:\users\ajay\desktop\test_1\" & a & ".xlsx"
                
                bk.Close True
            End If
        Next a
    End With
End Sub