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

 

[DutchKevin]

Hi Peter,
Works like a charm. thanks.
Yesterday I had posted below question in a seperate thread.
I will close the other thread and put a redirect to here.
Could you give this a look?

I'm looking for a way to still have the same export functionality but exclude some rows where in column J the status is set to "Closed".
Those I no longer need to report in seperate sheets/files.

The result required would be that the export of a datagroup is skipped, if all rows in a datagroup are closed, but also that out of (e.g.) 10 rows, only the 7 open ones are exported to the new sheets.
With datagroup I mean the unique values in the filter-by-column.

I've been working with several if-then's but the result never comes out as I want. either a whole group is wrongly skipped or the closed ones still show up in the output.

Hope this still makes sense and that you can translate it into code.
Thanks
Kevin

 

[VoG]

It is probably as easy to copy all the data then delete the Closed rows. Untested

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")
            With ws
                LR = .Range("J" & Rows.Count).End(xlUp).Row
                For i = LR To 2 Step -1
                    If .Range("J" & i).Value = "Closed" Then .Rows(i).Delete
                Next i
            End With
            iStart = iEnd + 1
        End If
    Next i
End With

 

[DutchKevin]

Hi Peter,
It breaks on the red part where you use Step

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:=xlPasteFormats
                ws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).copy Destination:=ws.Range("A2")
             With ws
                LR = .Range("J" & Rows.Count).End(xlUp).Row
                [COLOR=red]For i = LR To 2 Step[/COLOR][COLOR=black] -1[/COLOR]
                    If .Range("J" & i).Value = "Closed" Then .Rows(i).Delete
                Next i
            End With
            iStart = iEnd + 1
        End If
    Next i
End With

 

[VoG]

Please can you post the entire code so that I can test it.

 

[DutchKevin]

solved, it was double assigning data to variable i.
I now use k as variable in that If sequence and tested it ok.
works great now!!

 

[DEllis]

Wow!!! Thank you so much! This worked like a gem.

I appreciate your help. One day I will be able to answer questions for folks as well as all of you here on this forum.

Thanks again!

 

[lapta301]

VoG

I'm amazed at just how often this thread resurfaces and I get an email about it.

You must be pulling your hair out with the number of extra little bits people want and usually you provide the goods.

If I recall I did say quite frequently how good and flexible this code was and I'm still using it to this day.

I have no problem in saying on behalf of the many many people who I am sure are using this code - Thanks for all of your help and the very considerable amount of time and effort that you put in for the benefit of others.

lapta301 - the cause of this wonderful code

 

[blowfly]

I apologize for being late to the party but this has been a very educational thread. The final pieces that I have not been able to figure out are carrying forward page setup properties. I need a header, grid lines true, and top row to repeat when any individual sheets are printed. Thanks in advance for your help!! I am using the With ActiveSheet module from #50

 

[moh_salah8]

It's very nice code but, i need your help in this modefication if you have a time as i really need it in my work as i need to split the original shhet to many shhets according the languag code, each language in a sheet.

below the details of the original sheet:

First column for language name.
Language name always starts with two or three characters as shown:

ar
fa
fil-ph
gu
he
hi
id
kok
ku-arab
mr
ms
ne-np
or-in
pa
pa-arab
prs-af
sd-arab
th
ug-arab
ur
vi

-
I need to split the original sheet to 21 sheets according to the language name and the output sheet called by the language code name.

Thanks in advance.

 

[chinmayh]

Thank you so much

As per your PM this will allow copies of the separated sheets to be saved to individual workbooks.

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