Copy from range and append below VBA macro

Question

Present Data                            
                            
Header1 Header2 Header3         S-Amount    P-Amount    Q-Amount
AA  BB  CC          111 112 113
AA1 BB1 CC1         222 223 224
AA2 BB2 CC2         333 334 335
                            
                            
                            
                            
                            
I want like below:                          
                            
Header1 Header2 Header3 New Formatted Amt   Amount          
AA  BB  CC  S-Amount    111         
AA1 BB1 CC1 S-Amount    222         
AA2 BB2 CC2 S-Amount    333         
AA  BB  CC  P-Amount    112         
AA1 BB1 CC1 P-Amount    223         
AA2 BB2 CC2 P-Amount    334         
AA  BB  CC  Q-Amount    113         
AA1 BB1 CC1 Q-Amount    224         
AA2 BB2 CC2 Q-Amount    335         

I want to use VBA macro to do the above reformatting of the data as shown. Can anyone give some suggestions!

Answer 1

From Range1 to Array1 to Array2 to Range2

The Array - fast as lightning.

Sub CopyAppendData()

'-- Customize BEGIN --------------------
  Const cStrCell As String = "A1" 'Initial data starting cell range
  Const cIntEmpty As Integer = 1 'Empty rows between initial and resulting range
  Const cStrCol4 As String = "New Formatted Amt" 'Title of 4th resulting column
  Const cStrCol5 As String = "Amount" 'Title of 5th resulting column
'-- Customize END ----------------------

  Const cIntColIn As Integer = 6 'Number of columns of initial data
  Const cIntColRs As Integer = 5 'Number of columns of resulting data
''''''''''''''''''''''''''''''''''''''''
  Dim oRngIn As Range
  Dim oRngRs As Range
''''''''''''''''''''''''''''''''''''''''
  Dim arrIn As Variant
  Dim arrRs() As Variant
''''''''''''''''''''''''''''''''''''''''
  Dim loRowIn1 As Long
  Dim loRowIn2 As Long
  Dim iColIn1 As Integer
  Dim iColIn2 As Integer
''''''''''''''''''''''''''''''''''''''''
  Dim loRowRs1 As Long
  Dim loRowRs2 As Long
  Dim iColRs1 As Integer
  Dim iColRs2 As Integer
''''''''''''''''''''''''''''''''''''''''
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  Dim str1 As String
''''''''''''''''''''''''''''''''''''''''
  'Calculating data for the initial range/array.
  loRowIn1 = Range(cStrCell).Row
  iColIn1 = Range(cStrCell).Column
  iColIn2 = Range(cStrCell).Column + cIntColIn - 1
  loRowIn2 = Columns(iColIn1).End(xlUp).Row
  loRowIn2 = Cells(Rows.Count, iColIn1).End(xlUp).Row
  Set oRngIn = Range(Cells(loRowIn1, iColIn1), Cells(loRowIn2, iColIn2))

'  Debug.Print oRngIn.Address

''''''''''''''''''''''''''''''''''''''''
  'Paste initial range into initial array
  arrIn = oRngIn

'  str1 = "Initial Array" & vbCrLf
'  For i = LBound(arrIn) To UBound(arrIn)
'    str1 = str1 & vbCrLf
'    For j = LBound(arrIn, 2) To UBound(arrIn, 2)
'      str1 = str1 & Chr(9) & arrIn(i, j)
'    Next
'  Next
'  Debug.Print str1

''''''''''''''''''''''''''''''''''''''''
  'Populate resulting array
  ReDim arrRs(1 To (loRowIn2 - loRowIn1) * 3 + 1, 1 To cIntColRs)
  'Header (1st row)
  For i = 1 To 3: arrRs(1, i) = arrIn(1, i): Next
  arrRs(1, 4) = cStrCol4: arrRs(1, 5) = cStrCol5
  'Data
  For k = 0 To 2
    For j = 1 To 3
      For i = 2 To UBound(arrIn)
        arrRs((loRowIn2 - loRowIn1) * k + i, j) = arrIn(i, j)
        arrRs((loRowIn2 - loRowIn1) * k + i, 4) = arrIn(1, 4 + k)
        arrRs((loRowIn2 - loRowIn1) * k + i, 5) = arrIn(i, k + 4)
      Next
    Next
  Next

'  str1 = "Resulting Array" & vbCrLf
'  For i = LBound(arrRs) To UBound(arrRs)
'    str1 = str1 & vbCrLf
'    For j = LBound(arrRs, 2) To UBound(arrRs, 2)
'      str1 = str1 & Chr(9) & arrRs(i, j)
'    Next
'  Next
'  Debug.Print str1

''''''''''''''''''''''''''''''''''''''''
  'Calculating data for the resulting range.
  loRowRs1 = loRowIn2 + cIntEmpty + 1
  loRowRs2 = loRowRs1 + (loRowIn2 - loRowIn1) * 3 '1 for resulting header
  iColRs1 = iColIn1
  iColRs2 = iColRs1 + cIntColRs - 1
  Set oRngRs = Range(Cells(loRowRs1, iColRs1), Cells(loRowRs2, iColRs2))

'  Debug.Print oRngRs.Address

''''''''''''''''''''''''''''''''''''''''
  'Paste resulting array into resulting range
  oRngRs = arrRs

End Sub

You can add some more rows:

Header1 Header2 Header3 S-Amount    P-Amount    Q-Amount
AA      BB      CC      111         112         113
AA1     BB1     CC1     222         223         224
AA2     BB2     CC2     333         334         335
AA3     BB3     CC3     444         445         446
AA4     BB4     CC4     555         556         557