Copy to new worksheets

L

lapta301

Well-known Member
Joined
Nov 12, 2004
Messages
1,001
Office Version
  1. 365
Platform
  1. Windows
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
 
Sort by date Sort by votes
VoG,

Thanks for the time you spent on this. The output is perfect and exactly what i need. However, how do i amend so that the code starts the row count at row 10 (first line of data, row 9 header) and not count the columns but stop at G? Without this the code requires me to have data in each row and column (on the master) to create range which i have to format to be invisble.

Lastly and its a big ask but is there also anyway to carry the formating across to the output sheets?

FYI future reference, the Run Time errors in this thread that i and others have reported appears to be a result of specific cell formating on the master sheet (forced date format etc)

Indebited, Tarqs



Code: 
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
[/QUOTE]
 
Upvote 0
Maybe this

Code: 
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
    LastCol = 7
    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
            .Range(.Cells(9, 1), .Cells(9, LastCol)).Copy Destination:=ws.Cells(1, 1)
            .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
 
Upvote 0
Try

Rich (BB code): 
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
    LastCol = 7
    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
            .Range(.Cells(9, 1), .Cells(9, LastCol)).Copy Destination:=ws.Cells(1, 1)
            ws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
            .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

And if I see this thread resurrected again I think I will be sick :stickouttounge:
 
Upvote 0
Perhaps but this may not work depending on yoyr version of Excel (I think you need XL or later


Code: 
Option Explicit

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
    LastCol = 7
    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
            .Range(.Cells(9, 1), .Cells(9, LastCol)).Copy Destination:=ws.Cells(1, 1)
            .Range(.Cells(9, 1), .Cells(9, LastCol)).Copyws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
            .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
 
Upvote 0
this code is fantastic.

However, can i kindly ask; is it possible to include a way to be able to carry over subtotals? For example, this macro ceate separate sheets for each change in name. But if that name contains a "total", it creates a separate sheet for it as the name has technicaly changed because it has a total at the end of it..but i want this on the same sheet.

e.g

Name
KwikFit
KwitFit Total
Mail Marketing
Mail Marketing Total

I would like Both Kwik Fit entries separated into one sheet, and the mail marketing entries separated into another sheet..can this be done?

Thanks in Advance
Aldo
 
Upvote 0
this code is fantastic.

However, can i kindly ask; is it possible to include a way to be able to carry over subtotals? For example, this macro ceate separate sheets for each change in name. But if that name contains a "total", it creates a separate sheet for it as the name has technicaly changed because it has a total at the end of it..but i want this on the same sheet.

e.g

Name
KwikFit
KwitFit Total
Mail Marketing
Mail Marketing Total

I would like Both Kwik Fit entries separated into one sheet, and the mail marketing entries separated into another sheet..can this be done?

Thanks in Advance
Aldo
Click to expand...
Question re-posted here: http://www.mrexcel.com/forum/showthread.php?t=583470
 
Upvote 0
Hi Vog,
Big respect for your codes. I'm still learning VBA and I learn a lot from them.
In this version of (part of) your code it gives an error in the column width.
Code: 
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
                [COLOR=red]ws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths [/COLOR]
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).copy Destination:=ws.Range("A2")
 
            iStart = iEnd + 1
        End If
    Next i
End With
 
Upvote 0
Try

Code: 
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
 
                .Range(.Cells(1, 1), .Cells(1, LastCol)).Copy
                ws.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
                ws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
 
            iStart = iEnd + 1
        End If
    Next i
End With
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Data Validation List without duplicates
2 3 4
Replies
30
Views
1K
kvsrinivasamurthy
K
J
  • Solved
Copy data from a worksheet based on a change in criteria and then save the new workbook
Replies
5
Views
122
smozgur
smozgur
S
  • Question Question
Copying a table to new worksheet after it has been sorted from a previous worksheet
3 4 5
Replies
48
Views
1K
Logit
Logit
J
  • Solved
Speeding up VBA
Replies
9
Views
389
jvoss
J
D
  • Question Question
Modify a worksheet without registering it as a change
Replies
1
Views
288
Kaper
Kaper

Forum statistics

Threads
1,226,841
Messages
6,193,287
Members
453,788
Latest member
drcharle

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top