Copy to new worksheets

[lapta301]

Dear All

I have some spreadsheets containing substantial rows of data that come in from our main frame.

I need to copy the rows of data from Sheet1 to new sheets for each office with the sheets named after each office number that is in column H

The one I am currently working on extends from A1 to L2387 but the size changes each time although the sort field is always H. In this ine office 106 has 300 records and office 6300 has 860 records.

I have noticed that there is an apostrophe in front of the number but Excel will sort it properly after asking if I want text that looks like numbers sorted like numbers.

Many thanks

 

[VoG]

Can you post the particular code you want to change. There are several versions in this thread!

 

[Topher916]

My apologies this is the code from the second page of the thread.

Sub Lapta()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
Master = .Name
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To LastRow
If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Cells(iStart, iCol).Value
On Error GoTo 0
'ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A1")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
Folder = "Select the folder to save the workbooks"
Folder = GetDirectory(Folder)
If Folder = "" Then Exit Sub
Prefix = InputBox("Enter a prefix (or leave blank)")
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> Master Then
sh.Copy
Fname = Folder & "\" & Prefix & sh.Name & ".xls"
If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
Title:=Fname & " exists - select file to save as")
ActiveWorkbook.SaveAs Filename:=Fname
ActiveWorkbook.Close
End If
Next sh
Application.ScreenUpdating = True
End If
End Sub

 

[VoG]

Perhaps like this

sh.Copy
Fname = Folder & "\" & Prefix & sh.Name & ".xls"
If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
Title:=Fname & " exists - select file to save as")
ActiveWorkbook.SaveAs Filename:=Fname & Format(Date, "ddmmyyyy")
ActiveWorkbook.Close

 

[Topher916]

Sorry again, I had posted the wrong code that I was using it was actually:

Sub Lapta()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
Master = .Name
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To LastRow
If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Cells(iStart, iCol).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
Prefix = InputBox("Enter a prefix (or leave blank)")
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> Master Then
sh.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xls"
ActiveWorkbook.Close
End If
Next sh
Application.ScreenUpdating = True
End If
End Sub

The other code did not work for me and kept saying

Compile Error:

Sub or Function not defined

and where GetDirectory was highlighted.

I would like to use the latest code posted to this thread...if it helps I'm using Excel 2010 on Windows 7.

 

[VoG]

You need to follow the instructions here http://www.mrexcel.com/forum/showpost.php?p=1971251&postcount=12

 

[Tarqs]

Apologies but stumbled across this piece of code which is a dream come true.

The code is great, however I have couple of questions / problems / requirements? I can get the first part to work fine with the "reports / tabs" being created.

I then stumble across a problem when saving? Same as post 26 with the sh.Copy. I've tried changing to .xlsx and .csv but neith work. Am i missing any other settings?

Secondly my data set starts at row 10 with row nine and above being headers and formatting etc. How do amend the code to start from this point?

And lastly just to be difficult how do amend the code to only output a certain range of columns for example from A to AK (inclusive).

Apologies but anyone who could help a naive new user would be a life saver!

Thanks in advance

oh, using excel 2007

 

[VoG]

Try this

Sub Lapta()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(10, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(10, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 10
    For i = 10 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(9, LastCol)).Value = .Range(.Cells(1, 1), .Cells(9, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A10")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xlsx"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=51
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub

 

[Tarqs]

VoG,

Thanks for the response. I still seem to get a run-time erorr on the sh.Copy function. Tried this on another machine as well so not sure if a have a something setup up wrong??

Secondly and this is my fault for not being specific earlier but the code assumes that i have data in every row down to my header row at 9 and every column upto where i want it to stop.

Is there a way of starting the row count from the header row at 9 and to specify the column i want it to stop at instead to it counting across. I also only need it to copy the header row down onto the newly created sheets and not anything above the header row?

Sorry to be pain. Thanks again

 

[VoG]

Perhaps this

Sub Lapta()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(10, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(10, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 10
    For i = 10 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(9, 1), .Cells(9, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xlsx"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=51
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub

 

[Topher916]

Thanks for everything! I got it to work with finding the directory by the link you posted.

The code that was edited didn't exactly do what I wanted...I wanted to use the date in the cell as a reference to label the workbook file. But because of your post I edited the worksheet tab label with this:

If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = [COLOR="Red"]Format(.Cells(iStart, iCol).Value, "mm-dd-yyyy")[/COLOR]
            On Error GoTo 0
            'ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A1")
            iStart = iEnd + 1

This worked out perfectly. Thanks again for all your help and patience!