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

 

[eyee]

For the copying the workbooks only - looks like only the cells in the worksheet were cleared, but the worksheets were not deleted.

 

[AlphaFrog]

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))
    Set ShNew = Sh.Parent.Worksheets.Add
    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"
        With ActiveWorkbook
            With .Sheets(1)
                .Cells.Locked = False
                .Columns("A:C").Locked = True
                .Rows("1:8").Locked = True
                .Protect Password:=[COLOR="Blue"]"Secret"[/COLOR], Contents:=True
                .EnableSelection = xlUnlockedCells
            End With
            .SaveAs Filename:=FName, FileFormat:=xlExcel8
            .Close SaveChanges:=False
        End With
        Rng.AutoFilter
        ShNew.Cells.Clear
    Next Item
    Application.DisplayAlerts = False
        ShNew.Delete
    Application.DisplayAlerts = True
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

 

[eyee]

Thank you so much for you help - I have run into another issue.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
When the Macros saves off the workbooks, they save at a file size of 4.58 MB. The Macros I run is off an .xlsm that is 25.0 KB.<o></o>
<o></o>
I think this might because the Macros is copying all cells from the .xlsm and pasting into the .xls. Should I limit the copy or paste somehow? I want the final file to be .xls for 97-2003 compatibility.<o></o>
<o></o>
Thank you!<o></o>

 

[AlphaFrog]

I found this that may explain why it happens.
Saving to .xls in Excel 2007 increases the file size by 5x

This is the suggested solution; "...remove all formatting and theme before saving the to .xls file format (compatibility mode) using Office 2007"

I don't have Excel 2007 so I can't replicate the problem.

 

[eyee]

Thank you - I will take a look at this.

And there is no way to limit what is copied from the original to the new workbook. Like say I only want the first 30 or 40 rows. Wouldn't this cut down on the file size?

 

[AlphaFrog]

Thank you - I will take a look at this.

And there is no way to limit what is copied from the original to the new workbook. Like say I only want the first 30 or 40 rows. Wouldn't this cut down on the file size?

I don't know, but try this.

Change this line...

Sh[COLOR="Red"].Cells[/COLOR].SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")

To this. It limits the copy from the original to only the Used Range on the sheet. I probably should have had it this way in the code in the first place.

Sh[COLOR="Red"].UsedRange[/COLOR].SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")

Or this will limit the copy to the first 40 rows and 10 columns.

Sh.[COLOR="Red"]Range("A1:J40")[/COLOR].SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")

 

[eyee]

Awesome! That worked!

Sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")

 

[eyee]

Hi - Running into an issue with saving off the workbooks. I am receiving an error: Run-time error '1004': Method 'SaveAs' of object '_Workbook' failed. Debugger takes me to the line highlighted red below:

Here is the current Macro I am using:

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("v2_clean")
Set Rng = Sh.Range("C18", 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("C17", Sh.Range("C" & Rows.Count).End(xlUp))
Set ShNew = Sh.Parent.Worksheets.Add
For Each Item In List
ShNew.Name = Item
Rng.AutoFilter Field:=1, Criteria1:=Item
Sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
ShNew.Copy
FName = ThisWorkbook.Path & "\" & ShNew.Range("C18").Value & ".xls"
With ActiveWorkbook
With .Sheets(1)
.Rows("1:1").Hidden = True
.Columns("C").Hidden = True
.Columns("A").ColumnWidth = 9.86
.Columns("B").ColumnWidth = 17.14
.Columns("D").ColumnWidth = 10.71
.Columns("E:K").ColumnWidth = 8.43
.Columns("L").ColumnWidth = 12.14
.Columns("M").ColumnWidth = 12.01
.Cells.Locked = False
.Columns("A:C").Locked = True
.Rows("1:17").Locked = True
.Protect Password:="hrops", Contents:=True
.EnableSelection = xlUnlockedCells
.PageSetup.PrintArea = "$A$1:$M$46"
.PageSetup.Orientation = xlLandscape
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = 1
End With
Application.DisplayAlerts = False
.SaveAs Filename:=FName, FileFormat:=xlExcel8
.Close SaveChanges:=False
End With
Rng.AutoFilter
ShNew.Cells.Clear
Next Item
Application.DisplayAlerts = False
ShNew.Delete
Application.DisplayAlerts = True
Sh.Activate
Application.ScreenUpdating = True
End Sub