20170516

Problem 1 :- Filter Data and paste to other sheet

Dear Sir / madam,

Please see the attachment.  

I have a problem I want to copy data base on the Person name which i highlighted with yellow colour.
suppose if the person name "JKM" a sheet will created with the name "JKM" and the entire rows data relating to Jkm WILL copy to the new sheets of JKM.  if the person name is HM the the same rule will be follow.




Attachment

1. Filter Data and Make new Sheet with name




Sub Test()
Dim J As Integer
Dim sh As Worksheet
Sheet1.Range("M:M").Copy Sheet1.Range("Z:Z")
Sheet1.Range("Z:Z").RemoveDuplicates Columns:=1, Header:=xlNo
'Set sh = Worksheets
For J = Sheet1.Range("Z" & Rows.Count).End(xlUp).Row To 3 Step -1

    ActiveSheet.Range("A2:M" & Sheet1.Range("M" & Rows.Count).End(xlUp).Row).AutoFilter Field:=13, Criteria1:=Sheet1.Cells(J, 26)


Sheet1.Range("A2:M" & Sheet1.Range("M" & Rows.Count).End(xlUp).Row).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Set sh = Worksheets.Add
sh.Range("A1").PasteSpecial xlPasteAll
sh.Name = Sheet1.Cells(J, 26)
Sheet1.Activate
ActiveSheet.Range("A2:M" & Sheet1.Range("M" & Rows.Count).End(xlUp).Row).AutoFilter
Next J
Sheet1.Range("Z:Z").Delete

MsgBox "Thanks"

End Sub


2. Delete Old Sheet and Make new worksheet with updated Data

Sub Test()
Dim ws As Worksheet
Dim J As Integer
Dim sh As Worksheet
Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
Sheet1.Range("M:M").Copy Sheet1.Range("Z:Z")
Sheet1.Range("Z:Z").RemoveDuplicates Columns:=1, Header:=xlNo
'Set sh = Worksheets

For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
            ws.Delete
        End If
    Next

For J = Sheet1.Range("Z" & Rows.Count).End(xlUp).Row To 3 Step -1
Sheet1.Range("A2:M" & Sheet1.Range("M" & Rows.Count).End(xlUp).Row).AutoFilter Field:=13, Criteria1:=Sheet1.Cells(J, 26)
Sheet1.Range("A2:M" & Sheet1.Range("M" & Rows.Count).End(xlUp).Row).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Set sh = Worksheets.Add
sh.Range("A1").PasteSpecial xlPasteAll
sh.Name = Sheet1.Cells(J, 26)
Sheet1.Activate
ActiveSheet.Range("A2:M" & Sheet1.Range("M" & Rows.Count).End(xlUp).Row).AutoFilter
Next J
Sheet1.Range("Z:Z").Delete
Sheet1.Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Thanks"

End Sub