Macro to split data into seperate worksheets

[ExcelUser102]

Hi All,

I am stuck at one point with my macro. I have a macro below which splits the data in my workbook (Attached) into seperate workbooks on the basis of each change in data, and saves the new workbooks with the value available in column A. Everything else works perfectly with this code I just want the code to take the workbook name from Column B, not Column A as it is currently taking. If you take a look at the code below, you will know precisely what I am trying to acheive.



Sub Test()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim ShNew As Worksheet
Dim FName As String
Application.ScreenUpdating = False
' *** Change Sheet name to suit ***
Set Sh = Worksheets("Sheet1")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
Set ShNew = Worksheets.Add
ShNew.Name = Item
Rng.AutoFilter Field:=1, Criteria1:=Item
Sh.Cells.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
ShNew.Copy
FName = ThisWorkbook.Path & "\" & Item & ".csv"
ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
Rng.AutoFilter
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub



any help on this is highly appreciated as i am trying to find a solution to this for quiet some time now.

Thanks alot
Riz

 

[AlphaFrog]

This is a guess but try something like this....

FName = ThisWorkbook.Path & "\" & [COLOR="Red"]ShNew.Range("B2").Value[/COLOR] & ".csv"

 

[ExcelUser102]

Thank you so much for your answer it worked perfectly , thanks again

 

[eyee]

Hi,

This Macro is exactly what I was looking for, minus I need help with copying the first 8 rows to every sheet. I'm new to VBA and could use assistance.

I start the Item at C9:


Sub Test()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim ShNew As Worksheet
Dim FName As String
Application.ScreenUpdating = False
' *** Change Sheet name to suit ***
Set Sh = Worksheets("Query1")
Set Rng = Sh.Range("C9:C22" & Sh.Range("C22").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("C1:C22" & Sh.Range("C22").End(xlUp).Row)
For Each Item In List
Set ShNew = Worksheets.Add
ShNew.Name = Item
Rng.AutoFilter Field:=1, Criteria1:=Item
Sh.Cells.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
ShNew.Copy
FName = ThisWorkbook.Path & "\" & ShNew.Range("C2").Value & ".xls"
ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlExcel8
ActiveWorkbook.Close SaveChanges:=False
Rng.AutoFilter
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub

Thanks!
E

 

[AlphaFrog]

Give this a try....

Sub Test()
    Dim Sh     As Worksheet
    Dim Rng    As Range
    Dim c      As Range
    Dim List   As New Collection
    Dim Item   As Variant
    Dim ShNew  As Worksheet
    Dim FName  As String
    Application.ScreenUpdating = False
    ' *** Change Sheet name to suit ***
    Set Sh = Worksheets("Query1")
    Set Rng = Sh.Range("C9", Sh.Range("C" & Rows.Count).End(xlUp))
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("C8", Sh.Range("C" & Rows.Count).End(xlUp))
    For Each Item In List
        Set ShNew = Sh.Parent.Worksheets.Add
        ShNew.Name = Item
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Sh.Cells.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        ShNew.Copy
        FName = ThisWorkbook.Path & "\" & ShNew.Range("C9").Value & ".xls"
        ActiveWorkbook.SaveAs Filename:=FName ', FileFormat:=xlExcel8
        ActiveWorkbook.Close SaveChanges:=False
        Rng.AutoFilter
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

 

[eyee]

Great! Thank you - much appreciated.

Is there a way to copy to a new workbook without copying to a worksheet first? I am expecting ~450 data changes and could split this into multiple sheets first.

 

[AlphaFrog]

This creates one new worksheet and reuses it for each data filter.

    On Error GoTo 0
    Set Rng = Sh.Range("C8", Sh.Range("C" & Rows.Count).End(xlUp))
    [COLOR="Red"]Set ShNew = Sh.Parent.Worksheets.Add[/COLOR]
    For Each Item In List
        ShNew.Name = Item
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Sh.Cells.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        ShNew.Copy
        FName = ThisWorkbook.Path & "\" & ShNew.Range("C9").Value & ".xls"
        ActiveWorkbook.SaveAs Filename:=FName ', FileFormat:=xlExcel8
        ActiveWorkbook.Close SaveChanges:=False
        Rng.AutoFilter
        [COLOR="Red"]ShNew.Cells.Clear[/COLOR]
    Next Item
[COLOR="Red"]    Application.DisplayAlerts = False
        ShNew.Delete
    Application.DisplayAlerts = True[/COLOR]
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

 

[eyee]

Awesome! Last question I promise...

I want to protect and lock the first 8 rows - I know you get an error when trying to run Macros on a locked workbook. Is there any way to get around this?

 

[AlphaFrog]

This should allow the macro to run on your protected sheet. Change the password "secret" to suit.

    [color=green]' *** Change Sheet name to suit ***[/color]
    [color=darkblue]Set[/color] Sh = Worksheets("Query1")
    [color=red]Sh.Protect Password:=[color=blue]"Secret"[/color], UserInterfaceOnly:=True[/color]

 

[eyee]

But can the protection transfer to the other workbooks? Or better put - the master does not need the protection, but the subsequent workbooks do. Rows 1-8 and Columns A-C shall be locked.