Solved

Excel split/copy code

Posted on 2013-01-19
24
230 Views
Last Modified: 2013-01-21
Good morning Experts,
I need your help.
attached is a sample sheet prices.
I need few things done.
1- increase the values in cells by the amount in cell L1
2- Create new sheets based on Column A
3- Copy Header into all new sheets created, and copy the rows. (paste on new sheet Starting A7)
4- Find the same postal code in Column B, Copy Rows as well. (At the bottom of what has already been copied from previous). HOWEVER, when pasting, switch Column A with B and B with A.

Example: Postal Code (CORE)
I have 24 rows in Column A, 116 rows in Column B,
All will have to be copied to the new created sheet (Core) with headers.

I should have about 150 or so new sheets created
Every sheet will have about 140 rows plus header.

Any help is greatly appreciated.
Thank you.
SAMPLE.xlsx
0
Comment
Question by:Wass_QA
  • 14
  • 10
24 Comments
 

Author Comment

by:Wass_QA
ID: 38796350
Number of rows will differ on Sheet1 (All_Prices)
0
 

Author Comment

by:Wass_QA
ID: 38797422
Hello,
Here is part of the answer,
This will sort by column A, and create the new sheets.
I still need
1-Increase the values in cells by the amount in cell L1
4- Find the same postal code in sheet1 (ALL_PRICES) Column B, Copy Rows as well. (At the bottom of what has already been copied from previous). HOWEVER, when pasting, switch Column A with B and B with A.

Sub First_Split_Sheet_Create_New_Sheets()
Dim colToSort As Long
Dim Subcol As Long
Dim FirstAccount As String
Dim AccountCreated As Boolean
Dim i As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim Dest As Worksheet
Dim MaxRow As Long

'DELETE OLD SHEETS
For Each WS In Worksheets
Application.DisplayAlerts = False
    If WS.Name <> "All_Prices" Then
        WS.Delete
    End If
Next WS

'START
Set WB = ActiveWorkbook
Set WS = WB.Worksheets("All_Prices")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row

colToSort = 1
AccountCreated = False

'Force Sort by Account Name Col A,B asc
WS.UsedRange.Sort Key1:=WS.Columns("A"), Key2:=WS.Columns("B"), Header:=xlYes

For i = 2 To MaxRow
    If FirstAccount <> WS.Cells(i, colToSort) Then
        AccountCreated = False
        J = 1
        If Not Dest Is Nothing Then Dest.Columns.AutoFit
    End If
   
    If Not AccountCreated Then
        Application.ScreenUpdating = True
        '---> Create WS with Account Name
        WB.Worksheets.Add After:=WB.Worksheets(WB.Worksheets.Count)
        Set Dest = ActiveSheet
        Dest.Name = WS.Cells(i, colToSort)
        'WS.Activate
        'WS.UsedRange.EntireColumn.Copy
        'Dest.Columns.PasteSpecial Paste:=xlFormats
        WS.Range("1:1").Copy Dest.Cells(1, 1)
        FirstAccount = WS.Cells(i, colToSort)
        AccountCreated = True
        J = J + 1
        DoEvents
        Application.ScreenUpdating = False
    End If
       
    WS.Cells(i, 1).EntireRow.Copy
    Dest.Cells(J, 1).EntireRow.PasteSpecial
    J = J + 1
Next i

Application.ScreenUpdating = False
        Sheets("All_Prices").Select
    ActiveWindow.SmallScroll Down:=-16
    Range("A1").Select
End Sub

Any help is appreciated.
0
 

Author Comment

by:Wass_QA
ID: 38798742
Hello,
can anyone help Please..

Thank you.
0
 

Author Comment

by:Wass_QA
ID: 38799134
Hello,
I figured out how to increase the values.

so, I only have one issue left.
4- Find the same postal code in Column B, (as tab name),  Copy Row. (At the bottom of what has already been copied from previous on same tab). HOWEVER, when pasting, switch Column A with B and B with A.

Thanks for any help.
0
 

Author Comment

by:Wass_QA
ID: 38799393
Hello,
so this is what I have left.

Lookup Sheet name in coLumn "B", IF found and is not in Column"A", then copy entire ROW and paste special to sheet name (paste after last row)

Example,
Sheet name "Core"

if Core found in column B, AND Core is not in Column A, then copy row and paste in the core sheet, (after last row).

Thanks
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38801606
Hi, Wass_QA.

Please see attached. I've made some significant changes to speed things up, particularly writing data in blocks rather than individual rows. Please note the following...
(1) I noticed that you turned on ScreenUpdating when you added a new sheet, I assume that this was to give you a view of progress. However, this slowed things down significantly AND it would have been no use on the second pass (there are no new postcodes in column B, correct?), so I dropped it. The whole run is taking less that 150 seconds so I don't think it's much of a loss!
(2) You were using PasteSpecial, but not selecting a type, so it was the same as an ordinary paste. I assumed you wanted to drop formulas and changed it accordingly.
(3) I assumed that you don't want to copy more than once those entries where column A equals column B, so I didn't. (By the way, this increased the run time by 25%!)
(4) For the new sheets, I put on filters and freezeframe and set the column widths the same as "All_Prices".
(5) A big chunk of code is duplicated. If you're happy with my changes then I'll move this into a separate Sub.

I hope I've understood your requirements correctly. The code is...
Option Explicit

Sub First_Split_Sheet_Create_New_Sheets()
Dim colToSort As Long
Dim i As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim Dest As Worksheet
Dim MaxRow As Long
Dim xLast_Code As String
Dim xThis_Code As String
Dim xBook_Name As String
Dim xLast_Col  As Long
Dim xStart     As Long
Dim xDest_Row  As Long
Dim StartTime  As Variant

StartTime = Timer()

'DELETE OLD SHEETS
For Each WS In Worksheets
    If WS.Name <> "All_Prices" Then
        Application.DisplayAlerts = False
            WS.Delete
        Application.DisplayAlerts = True
    End If
Next WS

'START
Set WB = ActiveWorkbook
Set WS = WB.Worksheets("All_Prices")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
xBook_Name = WB.Name
xLast_Col = WS.Range("A1").SpecialCells(xlLastCell).Column

colToSort = 1
'AccountCreated = False

Application.ScreenUpdating = False

    'Force Sort by Account Name Col A,B asc
    WS.UsedRange.Sort Key1:=WS.Columns("A"), Key2:=WS.Columns("B"), Header:=xlYes
    
    For i = 2 To MaxRow
    
        xThis_Code = WS.Cells(i, 1)
    
        If xThis_Code <> xLast_Code Then
            If Not Sheet_Exists(xThis_Code, xBook_Name) Then
                WB.Worksheets.Add After:=WB.Worksheets(WB.Worksheets.Count)
                Set Dest = ActiveSheet
                Dest.Name = xThis_Code
                WS.Range("1:1").Copy Cells(1, 1)
                WS.Range("1:1").Copy
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Range("A1").AutoFilter
                Range("A2").Select
                ActiveWindow.FreezePanes = True
            End If
            xLast_Code = xThis_Code
            xStart = i
            DoEvents
        End If
         
        If xThis_Code <> WS.Cells(i + 1, colToSort) Then
            WS.Range(WS.Cells(xStart, 1), WS.Cells(i, xLast_Col)).Copy
            Sheets(xThis_Code).Range("A" & Sheets(xThis_Code).Range("A1").SpecialCells(xlLastCell).Row + 1).PasteSpecial xlPasteValues
        End If
        
    Next i
    
    'Force Sort by Account Name Col B,A asc
    WS.UsedRange.Sort Key1:=WS.Columns("B"), Key2:=WS.Columns("A"), Header:=xlYes
    
    xLast_Code = ""
    
    For i = 2 To MaxRow
    
        xThis_Code = WS.Cells(i, 2)
        
        If xThis_Code <> WS.Cells(i, 1) Then
        
            If xThis_Code <> xLast_Code Then
                If Not Sheet_Exists(xThis_Code, xBook_Name) Then
                    WB.Worksheets.Add After:=WB.Worksheets(WB.Worksheets.Count)
                    Set Dest = ActiveSheet
                    Dest.Name = xThis_Code
                    WS.Range("1:1").Copy Cells(1, 1)
                    WS.Range("1:1").Copy
                    Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Range("A1").AutoFilter
                    Range("A2").Select
                    ActiveWindow.FreezePanes = True
                End If
                xLast_Code = xThis_Code
                xStart = i
                DoEvents
            End If
             
            If (xThis_Code <> WS.Cells(i + 1, 2)) Or (xThis_Code = WS.Cells(i + 1, 1)) Then
                xDest_Row = Sheets(xThis_Code).Range("A1").SpecialCells(xlLastCell).Row + 1
                WS.Range(WS.Cells(xStart, 2), WS.Cells(i, 2)).Copy
                Sheets(xThis_Code).Range("A" & xDest_Row).PasteSpecial xlPasteValues
                WS.Range(WS.Cells(xStart, 1), WS.Cells(i, 1)).Copy
                Sheets(xThis_Code).Range("B" & xDest_Row).PasteSpecial xlPasteValues
                WS.Range(WS.Cells(xStart, 3), WS.Cells(i, xLast_Col)).Copy
                Sheets(xThis_Code).Range("C" & xDest_Row).PasteSpecial xlPasteValues
            End If
        
        End If
        
    Next i

    'Force Sort by Account Name Col A,B asc
    WS.UsedRange.Sort Key1:=WS.Columns("A"), Key2:=WS.Columns("B"), Header:=xlYes

    Sheets("All_Prices").Select
    Range("A1").Select
    
Application.ScreenUpdating = True

MsgBox ("Run completed in " & Format(Timer - StartTime, "#,##0.0") & " seconds)")

End Sub

Function Sheet_Exists(xSheet_Name As String, Optional xBook As String) As Boolean

If xBook = "" Then xBook = ActiveWorkbook.Name

Sheet_Exists = False

On Error Resume Next
    Sheet_Exists = (Workbooks(xBook).Sheets(xSheet_Name).Name = xSheet_Name)
On Error Resume Next

End Function

Open in new window

Regards,
Brian.SAMPLE--3----V3.xlsm
0
 

Author Comment

by:Wass_QA
ID: 38801690
Thank you, Thank you, Thank you.

Can I ask you for a small change,
1- The paste-special should start at A7.
2- Can you remove the filter at the end.
3-Can you Delete Column A.

Thanks again.
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38801732
Wass_QA,

2- Can you remove the filter at the end.
In "All_Prices"?

3- Can you Delete Column A.
In "All_Prices"?

Thanks,
Brian.
0
 

Author Comment

by:Wass_QA
ID: 38801763
Hello,
No,
on the newly crated sheets.
Thanks
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38801879
Wass_QA,

"2-" is easy, I just don't turn them on.

But "3-" is more confusing....
 - On the first paste, just don't copy column A.
 - On the second paste, just don't copy column B.

Correct?

Edit: Oh dear, what do you want the header to be - Col. A or Col. B!? Please send me a file with an "All_Prices" with two entries (one with "Core" in Column A and the second with it in Column B) and a second sheet with the results that you want. (Please use different values in column C so it's clear what's happening.)

Thanks,
Brian.
0
 

Author Comment

by:Wass_QA
ID: 38802133
Hello,
Your code is working perfect,

For, question2,
I will run this after I run your code, to remove the autofilter.

   For i = 1 To Worksheets.Count
        With Sheets(i)
            .AutoFilterMode = False
        End With
    Next

I just need to know how to start the paste at A7.
How to delete column A from all newly created sheets , (ATER I run your code and the new sheets are created).
Columns("A:A").Delete

thanks
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38802249
Wass_QA,

Rather than doing something for no good reason only to have to later undo it., why not simply not do it?! Please give me the two entries!

(An added bonus is that a much faster way of doing all this is to create a temporary sheet holding the doubled entries (but with the bad column dropped). By sorting this, there is a single pass of the data and each ofthe new sheets is written to once only. Only restriction is that it won;t cope with more than 500,000 rows - not a problem?)

Thanks,
Brian.
0
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 

Author Comment

by:Wass_QA
ID: 38802285
ok,
no worries about deleting Column,
how do I start at A7?

thanks
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38802318
I made all the changes an hour ago - just two little records, please, please, please!!!!
0
 

Author Comment

by:Wass_QA
ID: 38802389
Hello,
you didn't send me any changes to paste at A7.

Thanks,
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38803188
Wass_QA - 'cos you didn't send me the two entries!

If you send me those I can incorporate any necessary changes - otherwise we may end up with multiple versions.

I don't understand the problem - it's just two records from "All_Prices" in their output sheet!

Thanks,
Brian.
0
 

Author Comment

by:Wass_QA
ID: 38803321
Hello,
I'll use  your code, with out me changing anything.
can you make it paste at A7.

Thanks,
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38803459
Wass_QA,

This is a two way street -  and I do not understand why you are refusing to give me the two records.

If you're unhappy with my attitude, please feel free to have this question closed with zero points to me. You will have no problem getting someone to make the last changes.

Brian.
0
 

Author Comment

by:Wass_QA
ID: 38803501
Brian,

I have no idea what records you are referring to,
I had asked for 3 small changes.
1- The paste-special should start at A7.
2- Can you remove the filter at the end. ---- fixed
3-Can you Delete Column A

what records are you asking for?

As for your attitude, I don't have any issues what so ever,
You are trying to help and I appreciate your time and all your help.

Thanks,
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38803533
Thanks, Wass_QA.

I owe you an apology - my request was an update to a post so you may simply not have seen it.

I had made all the changes you requested but was very unsure of the Col. A/B one, so I requested an example...
Edit: Oh dear, what do you want the header to be - Col. A or Col. B!? Please send me a file with an "All_Prices" with two entries (one with "Core" in Column A and the second with it in Column B) and a second sheet with the results that you want. (Please use different values in column C so it's clear what's happening.)
...once I saw the output sheet, I'd know what, if anything, needed to be updated in my latest version.

Thanks,
Brian.
0
 

Author Comment

by:Wass_QA
ID: 38803620
Hi Brian,

Please see my sample attached..

Thanks again.
SAMPLE--3----V3.xlsm
0
 
LVL 26

Accepted Solution

by:
redmondb earned 500 total points
ID: 38803681
Thanks, Wass_QA.

OK, my version agreed with your output - with one possible issue. The earlier versions had a value in column L of "All_Prices" which, of course, carried through to column K in the new sheets. However, there's no value in your latest file.

So, should I include all input columns (with the A/B exception, of course) or stop at H?

The code is...
Option Explicit

Sub First_Split_Sheet_Create_New_Sheets()
Dim colToSort As Long
Dim i As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim Dest As Worksheet
Dim MaxRow As Long
Dim xLast_Code As String
Dim xThis_Code As String
Dim xBook_Name As String
Dim xLast_Col  As Long
Dim xStart     As Long
Dim xDest_Row  As Long
Dim StartTime  As Variant

StartTime = Timer()

'DELETE OLD SHEETS
For Each WS In Worksheets
    If WS.Name <> "All_Prices" Then
        Application.DisplayAlerts = False
            WS.Delete
        Application.DisplayAlerts = True
    End If
Next WS

'START

Set WB = ActiveWorkbook
Set WS = WB.Worksheets("All_Prices")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
xBook_Name = WB.Name
If WS.UsedRange.Rows.Count < 1 Then Debug.Print "!?" 'Force Excel to recalculate the last cell.
xLast_Col = WS.Range("A1").SpecialCells(xlLastCell).Column

colToSort = 1
'AccountCreated = False

Application.ScreenUpdating = False

    'Force Sort by Account Name Col A,B asc
    WS.UsedRange.Sort Key1:=WS.Columns("A"), Key2:=WS.Columns("B"), Header:=xlYes
    
    For i = 2 To MaxRow
    
        xThis_Code = WS.Cells(i, 1)
    
        If xThis_Code <> xLast_Code Then
            If Not Sheet_Exists(xThis_Code, xBook_Name) Then
                WB.Worksheets.Add After:=WB.Worksheets(WB.Worksheets.Count)
                Set Dest = ActiveSheet
                Dest.Name = xThis_Code
                WS.Range(WS.Cells(1, 2), WS.Cells(1, xLast_Col)).Copy Cells(7, 1)
                WS.Range(WS.Cells(1, 2), WS.Cells(1, xLast_Col)).Copy
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Range("A8").Select
                ActiveWindow.FreezePanes = True
            End If
            xLast_Code = xThis_Code
            xStart = i
            DoEvents
        End If
         
        If xThis_Code <> WS.Cells(i + 1, colToSort) Then
            WS.Range(WS.Cells(xStart, 2), WS.Cells(i, xLast_Col)).Copy
            Sheets(xThis_Code).Range("A" & Sheets(xThis_Code).Range("A1").SpecialCells(xlLastCell).Row + 1).PasteSpecial xlPasteValues
        End If
        
    Next i
    
    'Force Sort by Account Name Col B,A asc
    WS.UsedRange.Sort Key1:=WS.Columns("B"), Key2:=WS.Columns("A"), Header:=xlYes
    
    xLast_Code = ""
    
    For i = 2 To MaxRow
    
        xThis_Code = WS.Cells(i, 2)
        
        If xThis_Code <> WS.Cells(i, 1) Then
        
            If xThis_Code <> xLast_Code Then
                If Not Sheet_Exists(xThis_Code, xBook_Name) Then
                    WB.Worksheets.Add After:=WB.Worksheets(WB.Worksheets.Count)
                    Set Dest = ActiveSheet
                    Dest.Name = xThis_Code
                    WS.Range(WS.Cells(1, 2), WS.Cells(1, xLast_Col)).Copy Cells(7, 1)
                    WS.Range(WS.Cells(1, 2), WS.Cells(1, xLast_Col)).Copy
                    Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Range("A8").Select
                    ActiveWindow.FreezePanes = True
                End If
                xLast_Code = xThis_Code
                xStart = i
                DoEvents
            End If
             
            If (xThis_Code <> WS.Cells(i + 1, 2)) Or (xThis_Code = WS.Cells(i + 1, 1)) Then
                xDest_Row = Sheets(xThis_Code).Range("A1").SpecialCells(xlLastCell).Row + 1
                WS.Range(WS.Cells(xStart, 1), WS.Cells(i, 1)).Copy
                Sheets(xThis_Code).Range("A" & xDest_Row).PasteSpecial xlPasteValues
                WS.Range(WS.Cells(xStart, 3), WS.Cells(i, xLast_Col)).Copy
                Sheets(xThis_Code).Range("B" & xDest_Row).PasteSpecial xlPasteValues
            End If
        
        End If
        
    Next i

    'Force Sort by Account Name Col A,B asc
    WS.UsedRange.Sort Key1:=WS.Columns("A"), Key2:=WS.Columns("B"), Header:=xlYes

    Sheets("All_Prices").Select
    Range("A1").Select
    
Application.ScreenUpdating = True

MsgBox ("Run completed in " & Format(Timer - StartTime, "#,##0.0") & " seconds)")

End Sub

Function Sheet_Exists(xSheet_Name As String, Optional xBook As String) As Boolean

If xBook = "" Then xBook = ActiveWorkbook.Name

Sheet_Exists = False

On Error Resume Next
    Sheet_Exists = (Workbooks(xBook).Sheets(xSheet_Name).Name = xSheet_Name)
On Error Resume Next

End Function

Open in new window

Regards,
Brian.
0
 

Author Closing Comment

by:Wass_QA
ID: 38803696
This is exactly what I needed,
Thank you very much for all your time and help.
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38803728
Thanks, Wass_QA!

As I mentioned earlier, thiere is a possibly significantly speed-up - the data (with the column A/B changes) would be copied to a temporary sheet and sorted. This would allow the details for each postcode to be written as a single copy+Paste.

I'll keep an eye out here for at least a couple of weeks, so if you'd like me to do it, just shout!

Regards,
Brian.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Suggested Solutions

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now