VBA - AUTO FILTER I am looking for a macro which produces the below requirement.

Question

VBA - AUTO FILTER

I am looking for a macro which produces the below requirement.

1. It has to check the Column "Employee" for A and it has to apply autofilter (Criteria A) copy visible cell data and paste it into a new sheet. Then release filter

2.Then it has to check for Employee B and apply autofilter (Criteria B) copy visible cells data and paste it into a new sheet. Then release filter.

3.Then it has to check for Employee C, it has to exit sub (Since there is no data for Employee C

4.Then look for Employee D and copy paste to a new sheet.

5.Likewise it has to check Employee A to M, repeat the procedure. Wherever employee not there then exit sub.

Can you post a macro to carryout this effect?.

Employee Salary Deduction Net Payment Bank Account A 1000 100 900 ZZZZZ B 2000 200 1800 YYYYY D 3000 300 2700 XXXXX S 4000 400 3600 WWWWW G 5000 500 4500 VVVVV S 6000 600 5400 UUUUU A 7000 700 6300 TTTTT B 8000 800 7200 SSSSS D 9000 900 8100 RRRRR A 10000 1000 9000 QQQQQ B 11000 1100 9900 PPPPP S 12000 1200 10800 OOOOO A 13000 1300 11700 NNNNN G 14000 1400 12600 MMMMM D 15000 1500 13500 LLLLL G 16000 1600 14400 KKKKK

Explanation / Answer

$@$6993
%Try this code which assumes the Employee column is column A. The code will test all the names in Col A and copy the data to new worksheets. the worksheet will be given the name of the employee.

Sub Copy_Data()
Dim r As Range, LastRow As Long, ws As Worksheet
Dim v As Variant, s As String, LastRow1 As Long
Dim src As Worksheet
'Change name to the worksheet with the data on
Set src = Sheets("Sheet1")
LastRow = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row
For Each r In src.Range("A2:A" & LastRow)
   
         On Error Resume Next
         Set ws = Sheets(CStr(r.Value))
         On Error GoTo 0
         If ws Is Nothing Then
             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
             src.Rows(1).Copy ActiveSheet.Range("A1")
             LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
             src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
             Set ws = Nothing
         Else
             LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
             src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
             Set ws = Nothing
         End If
Next r
End Sub

Related Questions

Navigate

• Browse (All)
• Browse V
• Subjects

---

---

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.