从范围复制并追加到VBA宏下方

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         

我想使用VBA宏对数据进行上述重新格式化，如图所示。任何人都可以提出一些建议！真的会帮助我。谢谢！

Answer 1

从Range1到Array1到Array2到Range2

阵列-快如闪电。

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

您可以添加更多行：

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