VBA Copy, Move and Rename based on Cell Value

[unknownymous]

Hi Guys,

I have below data on a sheet with tab name "Data"

Date	NUM	NAME	TYPE	DATE	Subject	Note 1	Note 2
10/1/2000​	1​	Ben	Student	-	Math	-	-
10/1/2000​	2​	Ann	Student	-	Science	-	-
10/1/2000​	2​	Cher	Student	-	Math	-	-
11/1/2000​	2​	Joy	Student	-	Science	-	-
11/1/2000​	2​	Sam	Student	-	History	-	-
11/1/2000​	2​	Ken	Student	-	History	-	-
12/2/2000​	2​	Karl	Student	-	Math	-	-
12/2/2000​	2​	Sen	Student	-	Science	-	-
12/2/2000​	2​	Len	Student	-	Math	-	-

I wanted to create a macro where it will copy the data on another tab based on the date in column A as well as the header for all tabs.

So for this example, a new tab will be created for 10/1/2000 with a tab name "10.1.2000" since we can't use "/" in tab name.

RUN DATE	NUM	NAME	TYPE	DATE	Subject	Note 1	Note 2
10/1/2000​	1​	Ben	Student	-	Math	-	-
10/1/2000​	2​	Ann	Student	-	Science	-	-
10/1/2000​	2​	Cher	Student	-	Math	-	-

Another tab sheet will be created for 11/1/2000 (same case with 12/02/2000) with tab name 11.1.2000 and 12.02.2000

Tab "11.1.2000"

RUN DATE	NUM	NAME	TYPE	DATE	Subject	Note 1	Note 2
11/1/2000​	2​	Joy	Student	-	Science	-	-
11/1/2000​	2​	Sam	Student	-	History	-	-
11/1/2000​	2​	Ken	Student	-	History	-	-

Tab "12.2.2000"

RUN DATE	NUM	NAME	TYPE	DATE	Subject	Note 1	Note 2
12/2/2000​	2​	Karl	Student	-	Math	-	-
12/2/2000​	2​	Sen	Student	-	Science	-	-
12/2/2000​	2​	Len	Student	-	Math	-	-

Any help will be much appreciated.

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rDate As Range, rngList As Object, key As Variant, srcWS As Worksheet
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rngList = CreateObject("Scripting.Dictionary")
    For Each rDate In srcWS.Range("A2:A" & LastRow)
        If Not rngList.Exists(rDate.Value) Then
            rngList.Add rDate.Value, Nothing
        End If
    Next rDate
    For Each key In rngList
        With srcWS.Cells(1, 1).CurrentRegion
            .AutoFilter 1, key
        End With
        srcWS.UsedRange.SpecialCells(xlCellTypeVisible).Copy
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Replace(key, "/", ".")
        Cells(1, 1).PasteSpecial
    Next key
    Application.CutCopyMode = False
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[unknownymous]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rDate As Range, rngList As Object, key As Variant, srcWS As Worksheet
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rngList = CreateObject("Scripting.Dictionary")
    For Each rDate In srcWS.Range("A2:A" & LastRow)
        If Not rngList.Exists(rDate.Value) Then
            rngList.Add rDate.Value, Nothing
        End If
    Next rDate
    For Each key In rngList
        With srcWS.Cells(1, 1).CurrentRegion
            .AutoFilter 1, key
        End With
        srcWS.UsedRange.SpecialCells(xlCellTypeVisible).Copy
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Replace(key, "/", ".")
        Cells(1, 1).PasteSpecial
    Next key
    Application.CutCopyMode = False
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

This is is awesome! Thank you

 

[mumps]

You are very welcome.