Visual basic copy and paste in excel is very slow

Question

I have sheet which contains lots of column data, first column is date one in second column there are quantities and in the third one there are codes of item : the data looks like this :

date          qty   code   qty  code
01.01.2022    0      4355  2    4356
02.01.2022    0      4355  2    4356
03.01.2022    0      4355  2    4356
....................................

and I want to have like this :

date         qty  code
01.01.2022   0    4355
02.01.2022   0    4355
03.01.2022   0    4355
01.01.2022   2    4356
02.01.2022   2    4356
03.01.2022   2    4356

I wrote the code in visual basic for macro which cuts fourth and fifth columns pasts at the end of second and third columns and then deletes empty columns and continuous until there are no empty columns my code works but it takes hours to execute on 1000+ columns and I want to know if there is any possible way to optimize it.

code:

Sub CutAndPasteColumnsUntilEmpty()
    Dim lastRow As Long
    Dim i As Integer
    lastRow = ActiveSheet.UsedRange.Rows.Count

    Do Until IsEmpty(Range("D2")) And IsEmpty(Range("E2"))
        Range("D2:D" & lastRow).Cut Destination:=Range("B" & lastRow + 1)
        Range("E2:E" & lastRow).Cut Destination:=Range("C" & lastRow + 1)
        lastRow = ActiveSheet.UsedRange.Rows.Count
        Columns("D:E").Delete
    Loop
    
End Sub

Does this answer your question? [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — Dominique, Feb 10 '23 at 12:10

CLR · Answer 1 · 2023-02-10T11:38:50.257

This routine doesn't copy/paste any data.

It reads your table into an array, then creates a new array from that input array in the format you want. It then creates a new tab and writes the output to that tab. It should take seconds, not hours.

This will output by reading each row at a time.

Sub ReorganiseTable()

    'Declarations
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim NoOfRows As Long
    Dim NoOfColumnSets As Long
    Dim o As Long, r As Long, c As Long
    
    With ActiveSheet
    
        'Find Last Row of table
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        NoOfRows = LastRow - 1
        
        'Find Last Column of table
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        NoOfColumnSets = (LastColumn - 1) / 2
        
        'Copy table to array
        Dim ArrInput
        ArrInput = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(LastRow, LastColumn)).Value
        
        'Create output array for filling
        ReDim ArrOutput(1 To NoOfColumnSets * NoOfRows + 1, 1 To 3)
        
        'Copy headers across
        ArrOutput(1, 1) = ArrInput(1, 1)
        ArrOutput(1, 2) = ArrInput(1, 2)
        ArrOutput(1, 3) = ArrInput(1, 3)
        
        'Copy data across order by rows,columns
        o = 2
        For r = 2 To LastRow
            For c = 2 To LastColumn Step 2
                ArrOutput(o, 1) = ArrInput(r, 1)
                ArrOutput(o, 2) = ArrInput(r, c)
                ArrOutput(o, 3) = ArrInput(r, c + 1)
                o = o + 1
            Next
        Next
        
    End With
    
    'Create a new tab
    Worksheets.Add
    'Write output array to tab
    ActiveSheet.Cells(1, 1).Resize(UBound(ArrOutput), 3).Value = ArrOutput

End Sub

If you'd prefer it ordered by reading each column set at a time, invert the two For statements:

        'Copy data across order by rows,columns
        o = 2
        For c = 2 To LastColumn Step 2
            For r = 2 To LastRow
                ArrOutput(o, 1) = ArrInput(r, 1)
                ArrOutput(o, 2) = ArrInput(r, c)
                ArrOutput(o, 3) = ArrInput(r, c + 1)
                o = o + 1
            Next
        Next

score 0 · Answer 2 · answered Feb 10 '23 at 12:24

This is one of those occasions when the OP may be reaching for VBA too soon. The task can also be achieved via spreadsheet functions (if the Excel version is recent enough):

The formula in cell G2 is:

=LET(n,COUNTA(A:A)-1,arr,OFFSET(A2:E2,0,0,n),r,SEQUENCE(n*2),c,SEQUENCE(,3),IF(r>n,INDEX(arr,r-n,IF(c>1,c+2,c)),INDEX(arr,r,c)))

The LET function allows you to do intermediate calculations and store the result in a variable.

n = number of rows in the input data
arr = input array (resized from first row in data, for n rows)
r = a vector of rows (1 .. 2n) in the output table
c = a vector of columns (1 .. 3) in the output table

The final parameter is the calculation, which takes columns (1,2,3) from the input for the first n rows of the output table, and thereafter takes columns (1,4,5) for rows n+1 to 2n.

This has the benefits that the sheet can remain a .xlsx file (and hence avoid security warnings) and the output columns will update automatically (with calc set to auto) as new data is added to the input. It will also be faster than VBA.

VBasic2008 · Answer 3 · 2023-02-10T21:07:45.337

Stack Columns

It looks like it's written for any number of columns (Cols, Current) but it isn't (too lazy).
It only works for stacking column pairs to the first column.
The total number of columns is supposed to be odd (first + even).
It also includes the headers.

=LET(Data,A1:K7,Cols,2,
    Current,TAKE(Data,,1+Cols),First,DROP(TAKE(Data,,1),1),Other,DROP(Data,1,1+Cols),
    rCount,ROWS(First),cCount,COLUMNS(Other),cCountHalf,rCount*cCount/Cols,
    SeqFirst,MOD(SEQUENCE(cCountHalf)-1,rCount)+1,
    SeqOther,Cols*ROUNDUP(SEQUENCE(cCountHalf,,,Cols)/(Cols*rCount),0)-1,
VSTACK(Current,HSTACK(INDEX(First,SeqFirst),
    INDEX(Other,SeqFirst,SeqOther),INDEX(Other,SeqFirst,SeqOther+1))))

crusader86x · Answer 4 · 2023-02-10T23:03:34.143

Regarding to CLRs solution i would like to show my additional variant. With this one you can vary the columnsets as you wish.

Sub ReorganizeTable()

Dim arrA        As Variant
Dim arrB        As Variant
Dim c           As Long
Dim r           As Long
Dim isFirstRun  As Boolean
Dim ColumnSet   As Long
Dim RowSet      As Long
Dim maxCols     As Long
Dim maxRows     As Long
Dim maxSets     As Long
Dim ToggleCol   As Integer


ColumnSet = 3                                   'set your columns here

With Cells(1, 1).CurrentRegion                  'get dimension and array
    maxRows = .Rows.Count - 1                   '-1 = remove headers if available
    maxCols = .Columns.Count
    arrA = .Offset(1, 0).Resize(maxRows, maxCols)
End With

maxSets = maxCols / ColumnSet

ReDim arrB(1 To maxRows * maxSets, 1 To ColumnSet)

isFirstRun = True
    
    For c = 0 To maxCols - 1                   'must not start with 1, see ToggleCol below
        
        ToggleCol = c Mod ColumnSet + 1        'switches between 1 and 2 but has to start with 1
        
        If Not isFirstRun Then
            If ToggleCol = 1 Then
               RowSet = RowSet + maxRows
            End If
        End If
        
        
        For r = 1 To maxRows
            arrB(r + RowSet, ToggleCol) = arrA(r, c + 1)
        Next
        
        isFirstRun = False
        
    Next
    
Range("...").Resize(UBound(arrB, 1), UBound(arrB, 2)) = arrB   'set your outputrange here

End Sub

score -1 · Answer 5 · answered Feb 10 '23 at 21:16

-1

Add one line: Application.ScreenUpdating = False

Sub CutAndPasteColumnsUntilEmpty()
    Dim lastRow As Long
    Dim i As Integer
    lastRow = ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
    
    Do Until IsEmpty(Range("D2")) And IsEmpty(Range("E2"))
        Range("D2:D" & lastRow).Cut Destination:=Range("B" & lastRow + 1)
        Range("E2:E" & lastRow).Cut Destination:=Range("C" & lastRow + 1)
        lastRow = ActiveSheet.UsedRange.Rows.Count
        Columns("D:E").Delete
    Loop
    
End Sub

answered Feb 10 '23 at 21:16

ΑΓΡΙΑ ΠΕΣΤΡΟΦΑ

1,658
1
4
14

This will help, but it is lacking some critical pieces. You need to reset your ScreenUpdating back to True and include Error handling to make sure that if your code fails, ScreenUpdating will get reset. – Frank Ball Feb 10 '23 at 22:43
I reset ScreenUpdating back to True ONLY IF have to printPreview at some point. The VB must have internal logic and turns it back to true... try it. – ΑΓΡΙΑ ΠΕΣΤΡΟΦΑ Feb 11 '23 at 12:22

Visual basic copy and paste in excel is very slow

5 Answers5

Stack Columns