PDA

View Full Version : new logic need to add to the code



syed_iqbal
01-18-2017, 12:58 AM
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
01-18-2017, 08:50 AM
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