Visual basic copy and paste in excel is very slow - excel

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

Answer 1

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

Answer 2

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.

Answer 3

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

Answer 4

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

Answer 5

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