Is there a more time efficient way to perform the operation below? The macro i've made takes more than a minute per line

Question

I've got 1800 rows of data of approximately the format below:

id name id name dob (id name relation dob) x4

And I have to change the above to :

id name 

id name          dob

id name relation dob 

x4

The macro i made to manually switch formats takes more than a minute to process each line. Or my excel hangs.

The macro is :

    Sub autof()
'
' autof Macro
'
' Keyboard Shortcut: Ctrl+d
'
'
'
'
'
'
    Range("A2:AH2").Select
    Selection.Copy
    Sheets("Macro").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1:B1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("F").Select
    Range("A2").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("C1:E1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("F").Select
    Range("A3").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Range("C3").Select
    Application.CutCopyMode = False
    Selection.Cut
    Range("D3").Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("F1:I1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A4").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("J1:M1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A5").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("N1:Q1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A6").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("R1:U1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A7").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("V1:Y1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A8").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("Z1:AC1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A9").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    Range("AD1:AG1").Select
    Selection.Cut
    Sheets("F").Select
    Range("A10").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Macro").Select
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    Range("AH1").Select
    Selection.Cut
    Sheets("F").Select
    Range("E2").Select
    ActiveSheet.Paste
    Range("A8").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    Sheets("Macro").Select
    Range("L1").Select
    Range("A1").Select
    Sheets("Destroy").Select
    Selection.Delete Shift:=xlUp

'Loop
End Sub

I am not well versed with VBA. Just a lot of googling to understand what snippets do.

All of the `select` statements are killing the performance. See https://stackoverflow.com/q/10714251/62576 — Ken White, Sep 18 '21 at 03:08

score 1 · Answer 1 · answered Sep 18 '21 at 13:25

Option Explicit

Sub autof2()

    Dim wb As Workbook, wsIn As Worksheet, wsOut As Worksheet
    Dim lastrow As Long, r As Long, rOut As Long

    Set wb = ThisWorkbook
    Set wsIn = wb.Sheets("Sheet1")
    lastrow = wsIn.Cells(Rows.Count, "A").End(xlUp).Row

    Set wsOut = wb.Sheets("F")
    rOut = 1

    Application.ScreenUpdating = False
    For r = 2 To lastrow
        wsIn.Range("A" & r & ":B" & r).Copy wsOut.Range("A" & rOut)
        wsIn.Range("AH" & r).Copy wsOut.Range("E" & rOut)
        rOut = rOut + 1

        wsIn.Range("C" & r & ":D" & r).Copy wsOut.Range("A" & rOut)
        wsIn.Range("E" & r).Copy wsOut.Range("D" & rOut)
 
        rOut = rOut + 1

        wsIn.Range("F" & r & ":I" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

        wsIn.Range("J" & r & ":M" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

        wsIn.Range("N" & r & ":Q" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

        wsIn.Range("R" & r & ":U" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

        wsIn.Range("V" & r & ":Y" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

        wsIn.Range("Z" & r & ":AC" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

        wsIn.Range("AD" & r & ":AG" & r).Copy wsOut.Range("A" & rOut)
        rOut = rOut + 1

    Next
    Application.ScreenUpdating = True
    MsgBox rOut & " rows output", vbInformation

End Sub

Is there a more time efficient way to perform the operation below? The macro i've made takes more than a minute per line

1 Answers1