Solved

Excel split/copy code

Posted on 2013-01-19
24
248 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:W.E.B
  • 14
  • 10
24 Comments
 

Author Comment

by:W.E.B
ID: 38796350
Number of rows will differ on Sheet1 (All_Prices)
0
 

Author Comment

by:W.E.B
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:W.E.B
ID: 38798742
Hello,
can anyone help Please..

Thank you.
0
VMware Disaster Recovery and Data Protection

In this expert guide, you’ll learn about the components of a Modern Data Center. You will use cases for the value-added capabilities of Veeam®, including combining backup and replication for VMware disaster recovery and using replication for data center migration.

 

Author Comment

by:W.E.B
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:W.E.B
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:W.E.B
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:W.E.B
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:W.E.B
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
 

Author Comment

by:W.E.B
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:W.E.B
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:W.E.B
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:W.E.B
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:W.E.B
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:W.E.B
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

Master Your Team's Linux and Cloud Stack!

The average business loses $13.5M per year to ineffective training (per 1,000 employees). Keep ahead of the competition and combine in-person quality with online cost and flexibility by training with Linux Academy.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

770 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