以转置方式复制vba数组

Question

我有一个我转置的数组（我已经有了这个代码），见下文。我现在希望调整代码，以便可以进行以下操作。

数组中的每个项目都是重复的，例如

原始数组

1    5
2    7
3    11
4    15

变为

1 1 2 2  3  3  4  4
5 5 7 7 11 11 15  15

正如我提到的代码我做的转置我只是无法解决如何复制

Public Sub DynamicTranspose1()
Dim I As Variant
Dim J As Variant
Dim transArray() As Variant
Dim numRows As Integer
Dim numColumns As Integer
'—————————————-
'Get rows for dynamic array.
'—————————————-
Do
numRows = I
I = I + 1

 Loop Until Cells(I, "A").Value = ""
'———————————————-
'Get columns for dynamic array.
'———————————————-
I = 0
Do
numColumns = I
I = I + 1
Loop Until Cells(1, Chr(I + 64)).Value = ""
ReDim transArray(numRows - 1, numColumns - 1)
'—————————————————-
'Copy data from worksheet to array.
'—————————————————-
For I = 1 To numColumns
For J = 1 To numRows
transArray(J - 1, I - 1) = Cells(J, Chr(I + 64)).Value
Next J
Next I
maxcol = Split(Cells(1, numColumns).Address, "$")(1)
Range("A1:" & maxcol & numRows).ClearContents
'———————————————————————
'Copy data from array to worksheet transposed.
'———————————————————————
For I = 1 To numColumns
For J = 1 To numRows
Cells(I, Chr(J + 64)).Value = transArray(J - 1, I - 1)
Next J
Next I
End Sub

有人可以协助吗？

Answer 1

为什么不呢？

Dim arrIn As Variant
Dim arrOut As Variant
Dim i As Long, j As Long
'Get data from sheet
arrIn = Range("B9:C12").Value 'or wherever your data is located
'Duplicate the data & transpose
ReDim arrOut(1 To UBound(arrIn, 2), 1 To 2 * UBound(arrIn, 1))
For i = 1 To UBound(arrIn, 1)
    For j = 1 To UBound(arrIn, 2)
        arrOut(j, (2 * i) - 1) = arrIn(i, j)
        arrOut(j, 2 * i) = arrIn(i, j)
    Next j
Next i
'now slap it back onto the sheet
Range("G17").Resize(UBound(arrIn, 2), 2 * UBound(arrIn, 1)).Value = arrOut

循环不需要很长时间 - 除非您循环遍历单元格以一次一个地向/从单个单元格中读取/写入数据。这就是你所做的，而且确实需要很长时间。

在上面的代码中，您会注意到我不这样做。我立刻读完整个数组，最后一次写完所有数据; .Value对象的Range属性将允许您执行此操作。

读入数组后，循环遍历它就像它一样快。