• Status: Solved
• Priority: Medium
• Security: Public
• Views: 280

# Excel split/copy code

Good morning Experts,
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

Any help is greatly appreciated.
Thank you.
SAMPLE.xlsx
0
W.E.B
• 14
• 10
1 Solution

Author Commented:
Number of rows will differ on Sheet1 (All_Prices)
0

Author Commented:
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
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

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
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 Commented:
Hello,

Thank you.
0

Author Commented:
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 Commented:
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

Commented:
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
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
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

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
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

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
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

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
``````
Regards,
Brian.SAMPLE--3----V3.xlsm
0

Author Commented:
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

Commented:
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 Commented:
Hello,
No,
on the newly crated sheets.
Thanks
0

Commented:
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 Commented:
Hello,

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

Commented:
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 Commented:
ok,
how do I start at A7?

thanks
0

Commented:
0

Author Commented:
Hello,
you didn't send me any changes to paste at A7.

Thanks,
0

Commented:
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 Commented:
Hello,
I'll use  your code, with out me changing anything.
can you make it paste at A7.

Thanks,
0

Commented:
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 Commented:
Brian,

I have no idea what records you are referring to,
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

Commented:
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 Commented:
Hi Brian,

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

Commented:
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
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
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

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
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

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
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

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
``````
Regards,
Brian.
0

Author Commented:
This is exactly what I needed,
Thank you very much for all your time and help.
0

Commented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.