求助，有什么办法把数量排一起，金额排一起？

图片点不了
Option Explicit
Sub demo()
Dim arr, i%, col%, n%
arr = Range("a1").CurrentRegion
ReDim res(1 To UBound(arr), 1 To UBound(arr, 2))
For col = 1 To UBound(arr, 2) Step 2
n = n + 1
For i = 1 To UBound(arr)
res(i, n) = arr(i, col)
res(i, n + 3) = arr(i, col + 1)
Next i
Next col
Range("A16").Resize(UBound(res), UBound(res, 2)) = res
End Sub

截图的数据不是挺规律的吗？文件数据脱敏或者按真实情况模拟一部分数据，然后发上来，不然给你写了，你也不会用

沟通有点费劲啊，你试下是不是你想要的效果
Sub demo()
Dim arr, brr, crr, res, dic As Object, i&, j%, col%, lastRow&, n%
col = Cells(1, Columns.Count).End(1).Column
lastRow = Cells(Rows.Count, "n").End(3).Row
arr = Range("n1", Cells(lastRow, col))
Set dic = CreateObject("scripting.dictionary")
dic("数量") = "": dic("金额") = ""
For i = 1 To UBound(arr, 2)
If InStr(arr(1, i), "数量") Then
dic("数量") = dic("数量") & "," & i
Else
dic("金额") = dic("金额") & "," & i
End If
Next i
brr = Split(Mid(dic("数量"), 2), ",")
crr = Split(Mid(dic("金额"), 2), ",")
ReDim res(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 0 To UBound(brr)
n = n + 1
For j = 1 To UBound(arr)
res(j, n) = arr(j, Val(brr(i)))
res(j, n + UBound(arr, 2) / 2) = arr(j, Val(crr(i)))
Next j
Next i
Columns("n").Resize(, UBound(res, 2)) = ""
Range("n1").Resize(UBound(res), UBound(res, 2)) = res
End Sub