VBA macro runs too long

KPKP

New Member
Joined
Feb 8, 2022
Messages
10
Office Version
  1. 2007
Platform
  1. Windows
I have a macro that I run on opened CSV files. The files are typically only 20 or 30 rows of data. The macro reorders the data from bottom to top using an Autofill command and adjusts a few column settings. Nothing earth shattering. The "working" icon will often spin for more than 30 seconds before the results are displayed. Can anyone see what I've done wrong or suggest more efficient code? Appreciate your time!

VBA Code:
Sub FormatTextFile()
    Application.CutCopyMode = False     'this is equivalent to hitting ESC. Clears any previous clipboard entry before starting new command
    Application.ScreenUpdating = False
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Names.Add Name:="ALLROWS", RefersToR1C1:=Selection
    Selection.ClearContents
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "1"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "2"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "3"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "4"
    ActiveCell.Offset(-3, 0).Range("A1:A4").Select
    Selection.AutoFill Destination:=ActiveCell.Range("ALLROWS"), Type:= _
        xlFillDefault
    ActiveCell.Range("ALLROWS").Select
    Selection.Resize(, 7).Select
    Names.Add Name:="DATA", RefersToR1C1:=Selection
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=ActiveCell. _
        Range("ALLROWS"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange ActiveCell.Range("DATA")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 12
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 75
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.EntireColumn.Insert
    ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 6
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 12
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 12
    ActiveCell.Offset(0, -3).Range("A1").Select
    Application.CutCopyMode = False
   
'    This section of code moves Debit values from Column E to Column F in the CSV file.
    Do
        If ActiveCell.Value > 0 Then
            Selection.Cut
            ActiveCell.Offset(0, 1).Range("A1").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            ActiveCell.Offset(1, -1).Range("A1").Select
            Application.CutCopyMode = False
        Else
            ActiveCell.Offset(1, 0).Select
            Application.CutCopyMode = False
        End If
    Loop Until ActiveCell.Value = ""
    Range("B1").Select
    Application.CutCopyMode = False
End Sub
 
Last edited by a moderator:

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,079
Office Version
  1. 2010
Platform
  1. Windows
Try this:

VBA Code:
Sub FormatTextFile()
  Dim lr As Long, i As Long
  Dim a As Variant
  
  Application.ScreenUpdating = False
  lr = Range("A" & Rows.Count).End(3).Row
  Range("A1").Value = 1
  Range("A1:A" & lr).DataSeries xlColumns, xlLinear, xlDay, 1
  
  Range("A1:G" & lr).Sort key1:=Range("A1"), order1:=xlDescending, Header:=xlNo
  Range("B:B").ColumnWidth = 12
  Range("C:C").ColumnWidth = 75
  Range("D:D").EntireColumn.Insert
  Range("D:D").ColumnWidth = 6
  Range("E:E").ColumnWidth = 12
  Range("F:G").EntireColumn.Insert
  Range("H:H").ColumnWidth = 12
  
  '    This section of code moves Debit values from Column E to Column F in the CSV file.
  With Range("E1:F" & lr)
    a = .Value
    For i = 1 To UBound(a, 1)
      If a(i, 1) > 0 Then
        a(i, 2) = a(i, 1)
        a(i, 1) = ""
      End If
    Next
    .Value = a
  End With
  Range("B1").Select
End Sub
 
Solution

KPKP

New Member
Joined
Feb 8, 2022
Messages
10
Office Version
  1. 2007
Platform
  1. Windows
Sub FormatTextFile() Dim lr As Long, i As Long Dim a As Variant Application.ScreenUpdating = False lr = Range("A" & Rows.Count).End(3).Row Range("A1").Value = 1 Range("A1:A" & lr).DataSeries xlColumns, xlLinear, xlDay, 1 Range("A1:G" & lr).Sort key1:=Range("A1"), order1:=xlDescending, Header:=xlNo Range("B:B").ColumnWidth = 12 Range("C:C").ColumnWidth = 75 Range("D:D").EntireColumn.Insert Range("D:D").ColumnWidth = 6 Range("E:E").ColumnWidth = 12 Range("F:G").EntireColumn.Insert Range("H:H").ColumnWidth = 12 ' This section of code moves Debit values from Column E to Column F in the CSV file. With Range("E1:F" & lr) a = .Value For i = 1 To UBound(a, 1) If a(i, 1) > 0 Then a(i, 2) = a(i, 1) a(i, 1) = "" End If Next .Value = a End With Range("B1").Select End Sub
So awesome! Your version ran instantly and produced correct results. Thank you so much for taking the time to do this! You're my hero :)
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,079
Office Version
  1. 2010
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,167,514
Messages
5,854,175
Members
431,623
Latest member
ncorkren

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
Top