You could take all data into array and the paste values from there looping:
Sub test()
Dim i As Long, j As Long
Dim LastColumn As Long, LastRow As Long
Dim MyData As Variant
Dim HowManyCopies As Long, MyCounter As Long, CurrentRow As Long
Application.ScreenUpdating = False
'get last column, in your case 39, here is just 4
LastColumn = 4
'get last non blank row
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'all data into array, headers included
MyData = Range("A1").CurrentRegion.Value
'clear range except headers
Range(Cells(2, 1), Cells(LastRow, LastColumn)).Clear
'Duplicate rows. Loop trough each row of array
'we start at row 2 because 1 is headers
HowManyCopies = 4 'as example, just 4 duplicates of each row
CurrentRow = 2 'where to start duplicating
For i = 2 To UBound(MyData) Step 1
'loop trough counter until HowManyCopies is reached
For MyCounter = 1 To HowManyCopies Step 1
'loop trough each column and paste value
For j = 1 To LastColumn Step 1
Cells(CurrentRow, j).Value = MyData(i, j)
Next j
CurrentRow = CurrentRow + 1
Next MyCounter
Next i
Erase MyData 'clean variable
Application.ScreenUpdating = True
End Sub
The example above just duplicate a dataset of 5 rows and 4 columns each row 4 times but it's easy to adapt to 5000 rows and 39 columns (it will take longer, tough).
UPDATE: After doing some research, I've been able to design a more efficient code and tested with with a dataset of 5000 rows and 39 columns it took just 55 seconds to complete. The code is longer but it is worthless.
All credits goes to these resources:
How do I slice an array in Excel
VBA?
CPearson Functions For VBA
Arrays
The main sub is almost the same but the code is longer because it needs some auxiliary functions to work properly (check CPearson link to understand properly what the code does):
Option Explicit
'Source: http://www.cpearson.com/excel/vbaarrays.htm
' Error Number Constants
'''''''''''''''''''''''''''
Public Const C_ERR_NO_ERROR = 0&
Public Const C_ERR_SUBSCRIPT_OUT_OF_RANGE = 9&
Public Const C_ERR_ARRAY_IS_FIXED_OR_LOCKED = 10&
Sub test()
Dim Inicio As Date 'just to check how long, not needed
Inicio = Now 'just to check how long, not needed`
Dim i As Long, j As Long
Dim LastColumn As Long, LastRow As Long
Dim MyData As Variant, ThisDataRow() As Variant
Dim HowManyCopies As Long, MyCounter As Long, CurrentRow As Long
Application.ScreenUpdating = False
'get last column, in your case 39
LastColumn = 39
'get last non blank row, tested with 5000 rows of data
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'all data into array, headers included
MyData = Range("A1").CurrentRegion.Value
'clear range except headers
Range(Cells(2, 1), Cells(LastRow, LastColumn)).Clear
'Duplicate rows. Loop trough each row of array
'we start at row 2 because 1 is headers
HowManyCopies = 58 '58 copies of each row, 57+1 because we delete original one
CurrentRow = 2 'where to start duplicating
For i = 2 To UBound(MyData) Step 1
'loop trough counter until HowManyCopies is reached
For MyCounter = 1 To HowManyCopies Step 1
'paste values into row using CPearson codes
GetRow MyData, ThisDataRow, i
Range(Cells(CurrentRow, 1), Cells(CurrentRow, LastColumn)).Value = ThisDataRow
CurrentRow = CurrentRow + 1
Next MyCounter
Next i
Erase MyData 'clean variable
Erase ThisDataRow
Application.ScreenUpdating = True
Debug.Print Format(Now - Inicio, "hh:nn:ss") 'just to check how long, not needed
End Sub
Function GetRow(Arr As Variant, ResultArr As Variant, RowNumber As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetRow
' This populates ResultArr with a one-dimensional array that is the
' specified row of Arr. The existing contents of ResultArr are
' destroyed. ResultArr must be a dynamic array.
' Returns True or False indicating success.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
''''''''''''''''''''''''''''''
' Ensure Arr is an array.
''''''''''''''''''''''''''''''
If IsArray(Arr) = False Then
GetRow = False
Exit Function
End If
''''''''''''''''''''''''''''''''''
' Ensure Arr is a two-dimensional
' array.
''''''''''''''''''''''''''''''''''
If NumberOfArrayDimensions(Arr) <> 2 Then
GetRow = False
Exit Function
End If
''''''''''''''''''''''''''''''''''
' Ensure ResultArr is a dynamic
' array.
''''''''''''''''''''''''''''''''''
If IsArrayDynamic(ResultArr) = False Then
GetRow = False
Exit Function
End If
''''''''''''''''''''''''''''''''''''
' Ensure ColumnNumber is less than
' or equal to the number of columns.
''''''''''''''''''''''''''''''''''''
If UBound(Arr, 1) < RowNumber Then
GetRow = False
Exit Function
End If
If LBound(Arr, 1) > RowNumber Then
GetRow = False
Exit Function
End If
Erase ResultArr
ReDim ResultArr(LBound(Arr, 2) To UBound(Arr, 2))
For ColNdx = LBound(ResultArr) To UBound(ResultArr)
ResultArr(ColNdx) = Arr(RowNumber, ColNdx)
Next ColNdx
GetRow = True
End Function
Public Function NumberOfArrayDimensions(Arr As Variant) As Integer
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(Arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Public Function IsArrayDynamic(ByRef Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayDynamic
' This function returns TRUE or FALSE indicating whether Arr is a dynamic array.
' Note that if you attempt to ReDim a static array in the same procedure in which it is
' declared, you'll get a compiler error and your code won't run at all.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim LUBound As Long
' If we weren't passed an array, get out now with a FALSE result
If IsArray(Arr) = False Then
IsArrayDynamic = False
Exit Function
End If
' If the array is empty, it hasn't been allocated yet, so we know
' it must be a dynamic array.
If IsArrayEmpty(Arr:=Arr) = True Then
IsArrayDynamic = True
Exit Function
End If
' Save the UBound of Arr.
' This value will be used to restore the original UBound if Arr
' is a single-dimensional dynamic array. Unused if Arr is multi-dimensional,
' or if Arr is a static array.
LUBound = UBound(Arr)
On Error Resume Next
Err.Clear
' Attempt to increase the UBound of Arr and test the value of Err.Number.
' If Arr is a static array, either single- or multi-dimensional, we'll get a
' C_ERR_ARRAY_IS_FIXED_OR_LOCKED error. In this case, return FALSE.
'
' If Arr is a single-dimensional dynamic array, we'll get C_ERR_NO_ERROR error.
'
' If Arr is a multi-dimensional dynamic array, we'll get a
' C_ERR_SUBSCRIPT_OUT_OF_RANGE error.
'
' For either C_NO_ERROR or C_ERR_SUBSCRIPT_OUT_OF_RANGE, return TRUE.
' For C_ERR_ARRAY_IS_FIXED_OR_LOCKED, return FALSE.
ReDim Preserve Arr(LBound(Arr) To LUBound + 1)
Select Case Err.Number
Case C_ERR_NO_ERROR
' We successfully increased the UBound of Arr.
' Do a ReDim Preserve to restore the original UBound.
ReDim Preserve Arr(LBound(Arr) To LUBound)
IsArrayDynamic = True
Case C_ERR_SUBSCRIPT_OUT_OF_RANGE
' Arr is a multi-dimensional dynamic array.
' Return True.
IsArrayDynamic = True
Case C_ERR_ARRAY_IS_FIXED_OR_LOCKED
' Arr is a static single- or multi-dimensional array.
' Return False
IsArrayDynamic = False
Case Else
' We should never get here.
' Some unexpected error occurred. Be safe and return False.
IsArrayDynamic = False
End Select
End Function
Public Function IsArrayEmpty(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayEmpty
' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is really the reverse of IsArrayAllocated.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim LB As Long
Dim UB As Long
Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
' we weren't passed an array, return True
IsArrayEmpty = True
End If
' Attempt to get the UBound of the array. If the array is
' unallocated, an error will occur.
UB = UBound(Arr, 1)
If (Err.Number <> 0) Then
IsArrayEmpty = True
Else
''''''''''''''''''''''''''''''''''''''''''
' On rare occassion, under circumstances I
' cannot reliably replictate, Err.Number
' will be 0 for an unallocated, empty array.
' On these occassions, LBound is 0 and
' UBoung is -1.
' To accomodate the weird behavior, test to
' see if LB > UB. If so, the array is not
' allocated.
''''''''''''''''''''''''''''''''''''''''''
Err.Clear
LB = LBound(Arr)
If LB > UB Then
IsArrayEmpty = True
Else
IsArrayEmpty = False
End If
End If
End Function
Here's the test:
Took just 55 seconds.
