Messy code problem

M

MOB

Well-known Member
Joined
Oct 18, 2005
Messages
1,055
Office Version
  1. 365
Platform
  1. Windows
My boss (not a spreadsheet man :)) has created the following code to move some data around his spreadsheet, to be honest I'm quite impressed he has got this far!

I am going to improve it when I get chance, but an immediate issue is when the code runs, the last cell of excel becomes T1048574, and then the rest of the code fails as it is trying to shift data off the sheet.

Is there a very quick fix that I can apply in the meantime to do away with this issue?

Thanks

Code: 
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+f
'
    Range("A:A,C:C,E:E").Select
    Range("E1").Activate
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Amount"
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$G$35").AutoFilter Field:=2, Criteria1:="<>"
    Columns("A:D").Select
    Selection.Copy
    Range("H1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$K$35").AutoFilter Field:=3, Criteria1:="<>"
    Columns("A:D").Select
    Selection.Copy
    Range("Q1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Columns("A:G").Select
    Selection.Delete Shift:=xlToLeft
    Range("A:A,J:J").Select
    Range("J1").Activate
    Selection.NumberFormat = "m/d/yyyy"
    Range("C:C,K:K").Select
    Range("K1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("C:C,K:K").EntireColumn.AutoFit
    Columns("A:A").Select
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Add Key:=Range( _
        "A2:A1048564"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Paste Page").Sort
        .SetRange Range("A1:C1048564")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("I:I").Select
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Add Key:=Range( _
        "I2:I1048564"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Paste Page").Sort
        .SetRange Range("I1:K1048564")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("E:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Style = "Good"
    Rows("1:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Received"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "Payments Out"
    Rows("2:2").Select
    Selection.Font.Size = 11
    Selection.Font.Size = 12
    Selection.Font.Size = 14
    Selection.Font.Size = 16
    Selection.Font.Size = 18
    Selection.Font.Size = 20
    With Selection.Font
        .Name = "Arial"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("C9").Select

    Columns("A:A").Select
    Selection.Cut
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight
    Columns("B:B").Select
    Selection.Cut
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:B").Select
    Selection.Cut
    Columns("M:M").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Cut
    Columns("M:M").Select
    Selection.Insert Shift:=xlToRight
    Columns("B:B").Select
    Selection.Cut
    Columns("M:M").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:D").Select
    Selection.Cut
    Columns("O:O").Select
    Selection.Insert Shift:=xlToRight
End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
This is just a recorded macro...indeed needs a lot of cleaning. Anything finishing with
Code: 
.select
and starting with
Code: 
Selection.
should be united.

Which line blocks?
A dirty way is to start the macro with
Code: 
On error resume next
to keep going but the result might be different then
 
Last edited:
Upvote 0
Fails at Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

At that point the sheet thinks row 1048574 is the last one so I assume the XL down fails due to this?
 
Upvote 0
Code: 
[/FONT][/COLOR][COLOR=#222222][FONT=Verdana]Rows("1:3").Select[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove[/FONT][/COLOR][COLOR=#222222][FONT=Verdana]
to
Code: 
[/FONT][/COLOR][COLOR=#222222][FONT=Verdana]Rows("1:3").Insert[/FONT][/COLOR][COLOR=#222222][FONT=Verdana]
​
 
Upvote 0
Thanks - I thought that would fix it but it fails again at that point, as the last rows is again 1048574

Confused :(
 
Upvote 0
How does this fare?
Code: 
    Range("A:A,C:C,E:E").Delete Shift:=xlToLeft
    
    Cells.EntireColumn.AutoFit
    
    Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("B1").Copy Range("C1")
    
    Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        
    Range("C1").Value = "Amount"
    
    Rows("1:1").AutoFilter
    
    ActiveSheet.Range("$A$1:$G$35").AutoFilter Field:=2, Criteria1:="<>"
    Columns("A:D").Copy
    Range("H1").PasteSpecial Paste:=xlPasteValues
    
    Rows("1:1").AutoFilter
    
    ActiveSheet.Range("$A$1:$K$35").AutoFilter Field:=3, Criteria1:="<>"
    Columns("A:D").Copy
    Range("Q1").PasteSpecial Paste:=xlPasteValues
    
    Rows("1:1").AutoFilter
    
    Columns("A:G").Delete Shift:=xlToLeft
    
    Range("J1").NumberFormat = "m/d/yyyy"
    
    Range("C:C,K:K").Delete Shift:=xlToLeft
    
    Range("C:C,K:K").EntireColumn.AutoFit
    
    
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Add Key:=Range( _
        "A2:A1048564"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Paste Page").Sort
        .SetRange Range("A1:C1048564")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Add Key:=Range( _
        "I2:I1048564"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Paste Page").Sort
        .SetRange Range("I1:K1048564")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Columns("E:H").Delete Shift:=xlToLeft
    Columns("D:D").Style = "Good"
    Rows("1:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("A2").Value = "Received"
    Range("E2").Value = "Payments Out"
    
    With Rows("2:2").Font
        .Name = "Arial"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

    Columns("A:A").Cut
    Columns("K:K").Insert Shift:=xlToRight
    
    Columns("B:B").Cut
    Columns("K:K").Insert Shift:=xlToRight
    
    Columns("A:B").Cut
    Columns("M:M").Insert Shift:=xlToRight
    
    Columns("A:A").Cut
    Columns("M:M").Insert Shift:=xlToRight
    
    Columns("B:B").Cut
    Columns("M:M").Insert Shift:=xlToRight
    
    Columns("A:D").Cut
    
    Columns("O:O").Insert Shift:=xlToRight
 
Upvote 0
That does work well thanks, but with only 6 rows of data it is taking quite a long time to run, probably a minute or so?

Can it be sped up somehow?
 
Upvote 0
Do you know which parts are slowing things down?

You might be able to figure that out by stepping through the code with F8.
 
Upvote 0
MOB said:
That does work well thanks, but with only 6 rows of data it is taking quite a long time to run, probably a minute or so?

Can it be sped up somehow?
Click to expand...

I thing changing Textocolumn with split(expression,delimiter,[compare]) would reduce execution time. The best way is definitely to put in an Array and print it the way you want -> maybe use a pre-template from a hidden sheet.
Another usual approach to reduce time is to stop screen updates (the macro does what it has to do without showing the user, so he does not see the screen 'jumping' quickly from a range to another) as well as calculation (no calculation during te macro then automatic):
Code: 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Range("A:A,C:C,E:E").Delete Shift:=xlToLeft
    Cells.EntireColumn.AutoFit
    Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Copy Range("C1")
    Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Range("C1").Value = "Amount"
    Rows("1:1").AutoFilter
    ActiveSheet.Range("$A$1:$G$35").AutoFilter Field:=2, Criteria1:="<>"
    Columns("A:D").Copy
    Range("H1").PasteSpecial Paste:=xlPasteValues
    Rows("1:1").AutoFilter
    ActiveSheet.Range("$A$1:$K$35").AutoFilter Field:=3, Criteria1:="<>"
    Columns("A:D").Copy
    Range("Q1").PasteSpecial Paste:=xlPasteValues
    Rows("1:1").AutoFilter
    Columns("A:G").Delete Shift:=xlToLeft
    Range("J1").NumberFormat = "m/d/yyyy"
    Range("C:C,K:K").Delete Shift:=xlToLeft
    Range("C:C,K:K").EntireColumn.AutoFit
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Add Key:=Range( _
        "A2:A1048564"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Paste Page").Sort
        .SetRange Range("A1:C1048564")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Paste Page").Sort.SortFields.Add Key:=Range( _
        "I2:I1048564"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Paste Page").Sort
        .SetRange Range("I1:K1048564")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("E:H").Delete Shift:=xlToLeft
    Columns("D:D").Style = "Good"
    Rows("1:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Value = "Received"
    Range("E2").Value = "Payments Out"
    With Rows("2:2").Font
        .Name = "Arial"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Columns("A:A").Cut
    Columns("K:K").Insert Shift:=xlToRight
    Columns("B:B").Cut
    Columns("K:K").Insert Shift:=xlToRight
    Columns("A:B").Cut
    Columns("M:M").Insert Shift:=xlToRight
    Columns("A:A").Cut
    Columns("M:M").Insert Shift:=xlToRight
    Columns("B:B").Cut
    Columns("M:M").Insert Shift:=xlToRight
    Columns("A:D").Cut
    Columns("O:O").Insert Shift:=xlToRight
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
Help with Vba Code
Replies
3
Views
146
Coyotex3
C
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
198
Coco1
C
D
  • Solved
Use the same macro on a weekly file which contains date info
Replies
1
Views
234
John_w
J
C
  • Solved
How to not set a range in VBA
Replies
7
Views
382
Coco1
C
G
  • Question
How can i extract the correct leave time on this code?
Replies
1
Views
355
rlv01
R

Forum statistics

Threads
1,214,622
Messages
6,120,580
Members
448,972
Latest member
Shantanu2024

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