Move data into new sheet

[meakashgfx]

Hi,

I have almost 70 employees monthly login/Logout data in one sheet.

I want to create new sheet with each unique value and move the monthly data into there.

Here is a screenshot: Screenshot by Lightshot
Is it possible to make it by using ASAP utilities? or Please help me with the VBA.

Thanks in Advance!
Akash

 

[KeepTrying]

Hi,

Please see code below with following caveats:
- code deletes cells on existing Name sheets
- code adds new Name sheets
- so it assumes all data are on sheet "Shahadat"
- code does not affect other (not Name related) sheets

Sub Move_data_into_new_sheet()


Dim D As Object, i  As Long, X, Rng As Range, Sh As Worksheet, Van() As Boolean


Application.ScreenUpdating = False


Set Rng = ThisWorkbook.Sheets("Shahadat").UsedRange
Set D = CreateObject("Scripting.Dictionary")


'Read unique values in column A to Dictionary object
For i = 2 To Rng.Rows.Count
    D(CStr(Rng.Cells(i, 1))) = ""
Next i


ReDim Van(i = 0 To D.Count - 1)
X = D.keys


'Clear cells for existing Name sheets and add new Name sheets:
For Each Sh In ThisWorkbook.Worksheets
    For i = 0 To D.Count - 1
        If Sh.Name = X(i) Then
            Van(i) = True
            Exit For
        End If
    Next i
Next Sh
For i = 0 To D.Count - 1
    If Van(i) Then
        Sheets(X(i)).Cells.Clear
    Else
        Sheets.Add , Sheets(Sheets.Count)
        ActiveSheet.Name = X(i)
    End If
Next i


'Filter Name on sheet "Shahadat" and copy-paste content to individual Name sheets:
If Sheets("Shahadat").AutoFilterMode = True Then Sheets("Shahadat").AutoFilterMode = False
Rng.AutoFilter


For i = 0 To D.Count - 1
    Rng.AutoFilter 1, X(i), xlFilterValues
    Rng.SpecialCells(xlCellTypeVisible).Copy Sheets(X(i)).Range("a1")
Next i




Application.ScreenUpdating = True


End Sub

I hope it'll work for you as well.

Regards,

 

[RudiS]

Try this code...

Note: Code does NOT check for duplicate sheet names! If a duplicate is encountered, it will debug!

Sub SplitToSheet()
Dim sh As Worksheet
Dim r As Range
Dim i As Integer
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    sh.Range("A1").CurrentRegion.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1"), Unique:=True
    Set r = Range("F2", Cells(Rows.Count, "F").End(xlUp))
    For i = r.Rows.Count To 1 Step -1
        Sheets.Add(After:=ActiveSheet).Name = sh.Range("F2").Value
        sh.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=sh.Range("F1:F2"), Unique:=False
        sh.Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
        ActiveSheet.Range("A1").CurrentRegion.Columns.AutoFit
        sh.ShowAllData
        sh.Range("F2").Delete Shift:=xlUp
    Next i
    sh.Select
    sh.Columns("F:F").Delete
    Application.ScreenUpdating = True
End Sub

 

[meakashgfx]

it works like a superman!

Thanks you so much!

 

[meakashgfx]

Felling Wonderful!

 

[KeepTrying]

Is this my code? You're welcome

Have a great day.

Regards,