VBA -在分散的列中转储数组

Question

新到VBA，我试图通过以分散的方式将3个不同的数组转储到单行中来创建报告。我的意思是我想做以下事情:

Arr1 (A, B, C, D, E)Arr2 (1,2,3,4,5)ar3 (q, w, x, y, z)

在报告:

动态Range1:(1, q, B 2 w, C, 3 x, D, 4, y, E, 5, z)

这可行吗?

到目前为止，我已经使用了以下代码，但是它没有保持我正在寻找的顺序。

任何帮助将非常感激!(:

Sub GETDATA(ws As Worksheet)
Dim PARRAYT() As Variant
Dim QARRAYT() As Variant
Dim DARRAYT() As Variant
'''''
'----------------
'PRICE ARRAY
'----------------

Dim PARRAY() As Variant
Dim Pws As Worksheet, Pi%, Pmsg$
ReDim PARRAY(0 To 0)
For Each Pws In ActiveWorkbook.Worksheets
Pws.Activate

If Pws.Visible = xlSheetVisible Then
If Len(PARRAY(0)) = 0 Then
PARRAY(0) = Cells.Find(What:="Sub Total*:", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(0, 1).Value
Else
ReDim Preserve PARRAY(0 To UBound(PARRAY) + 1)
PARRAY(UBound(PARRAY)) = Cells.Find(What:="Sub Total*:", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(0, 1).Value


End If
End If
Next Pws
'Message for Price Array
Pmsg = ""
For Pi = LBound(PARRAY) To UBound(PARRAY)
Pmsg = Pmsg & Pi + 1 & ". " & PARRAY(Pi) & vbCrLf
Next Pi
MsgBox "Visible prices in array:" & vbCrLf & Pmsg, , "Array of prices"

'----------------
'DESCRIPTION ARRAY
'----------------
Dim DARRAY() As Variant
Dim Dws As Worksheet, Di%, Dmsg$
ReDim DARRAY(0 To 0)
For Each Dws In ActiveWorkbook.Worksheets
Dws.Activate

If Dws.Visible = xlSheetVisible Then
If Len(DARRAY(0)) = 0 Then
DARRAY(0) = Cells.Find(What:="SKU", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(1, -2).Value

Else
ReDim Preserve DARRAY(0 To UBound(DARRAY) + 1)
DARRAY(UBound(DARRAY)) = Cells.Find(What:="SKU", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(1, -2).Value


End If
End If

'Mesage for Desciption array
Next Dws
Dmsg = ""
For Di = LBound(DARRAY) To UBound(DARRAY)
Dmsg = Dmsg & Di + 1 & ". " & DARRAY(Di) & vbCrLf
Next Di
MsgBox "Visible  descriptions in DARRAY:" & vbCrLf & Dmsg, , "DARRAY of descriptions"
'----------------
'QUOTE ARRAY
'----------------
Dim QARRAY() As Variant
Dim Qws As Worksheet, Qi, Qmsg
ReDim QARRAY(0 To 0)
For Each Qws In ActiveWorkbook.Worksheets
Qws.Activate

If Qws.Visible = xlSheetVisible Then
If Len(QARRAY(0)) = 0 Then
QARRAY(0) = Cells.Find(What:="SKU", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(-7, 2).Value
QARRAY(UBound(QARRAY)) = Right((QARRAY(UBound(QARRAY))), 8)
Else
ReDim Preserve QARRAY(0 To UBound(QARRAY) + 1)
QARRAY(UBound(QARRAY)) = Cells.Find(What:="SKU", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(-7, 2).Value
QARRAY(UBound(QARRAY)) = Right((QARRAY(UBound(QARRAY))), 8)

End If
End If
'Message for Quote Array
Next Qws
Dmsg = ""
For Qi = LBound(QARRAY) To UBound(QARRAY)
Qmsg = Qmsg & Qi + 1 & ". " & QARRAY(Qi) & vbCrLf
Next Qi
MsgBox "Visible quotes in QARRAY:" & vbCrLf & Qmsg, , "QARRAY of quotes"""
''''''''''''''''''''''''
'LOGS ARRAY INTO QLOGS
'''''''''''''''''''''''
Dim wsDest As Worksheet
Dim Rbase As Range
Dim lCopyLastRow As Long
Dim i As Integer
'Rdest is the range the arrays will be dumped into
Dim Rdest As Range
LQ = LBound(QARRAY)
UQ = UBound(QARRAY)
Set wsDest = Workbooks("TrackerACG.xlsm").Sheets("QLogs")
DestLR = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
Set Rbase = wsDest.Range("N" & DestLR)
'This works, kinda:

Set Rdest = Rbase.Resize(1, UQ + 1)
For i = 1 To UQ
Rdest.Value = QARRAY
Rdest.Offset(0, UQ + 1).Value = DARRAY
Rdest.Offset(0, UQ + UQ + 2).Value = PARRAY
Next i

Answer 1

请尝试下一种转储方式。如果您希望返回的数组内容在活动工作表的第一行中被删除，请检查是否为空。如果是，您应该取消最后一行代码的注释:

Sub dumpingArrays()
Dim Arr1, Arr2, Arr3, arrDmp, i As Long, k As Long
Arr1 = Array("A", "B", "C", "D", "E")
Arr2 = Array(1, 2, 3, 4, 5)
Arr3 = Array("Q", "w", "X", "Y", "Z")

ReDim arrDmp(UBound(Arr1) + UBound(Arr2) + UBound(Arr3) + 2)

For i = 0 To UBound(Arr1)
arrDmp(k) = Arr1(i): k = k + 1
arrDmp(k) = Arr2(i): k = k + 1
arrDmp(k) = Arr3(i): k = k + 1
Next i

Debug.Print Join(arrDmp, "|")

'If the active sheet has its first row empty, please uncomment the next code line,
'to drop the dumped array content:
'ActiveSheet.Range("A1").Resize(1, UBound(arrDmp) + 1).Value = arrDmp
End Sub

请在测试后发送一些反馈…