[英]Excel VBA, combine 2 sets of data into a single array and remove blank rows
I've been using stackoverflow as a great reference tool for VBA.我一直使用 stackoverflow 作为 VBA 的一个很好的参考工具。
I've got 2, 2-column sets of data as shown below.我有 2、2 列数据集,如下所示。
My goal is to have a user input data into those 2 columns, create a single 2-column array with that info, and remove blank rows from that array, and then create a drop-down containing the info from the first column of the combined array.我的目标是让用户在这 2 列中输入数据,使用该信息创建一个 2 列数组,并从该数组中删除空白行,然后创建一个下拉列表,其中包含组合的第一列中的信息大批。 The second column will be used for voltage references.第二列将用于电压参考。 (the header not being part of the array.) (header 不是阵列的一部分。)
What i've done is create 2 arrays at first, and combine them.我所做的是首先创建 2 个 arrays,然后将它们组合起来。 I'm not sure if this is the best method, I need something that will work fast and I'm not sure how to properly remove the rows.我不确定这是否是最好的方法,我需要一些可以快速工作的东西,我不确定如何正确删除行。 The code is below:代码如下:
Sub test1()
Dim CombinedArray As Variant
Dim SWGRArray As Variant
Dim MCCArray As Variant
SWGRArray = Sheets("Worksheet").Range(Cells(3, 8), Cells(19, 9)).value
MCCArray = Sheets("Worksheet").Range(Cells(3, 10), Cells(19, 11)).value
CombinedArray = MergeArrays(SWGRArray, MCCArray)
End Sub
Public Function MergeArrays(ParamArray Arrays() As Variant) As Variant
' merges multiple arrays into a single array.
' ParamArray is an array listing other arrays
' Thanks to 'Tom' via https://stackoverflow.com/questions/46051448/excel-vba-joining-two-arrays
Dim i As Long, J As Long, cnter As Long, UBoundArr As Long, OldUBoundArray As Long
Dim arr() As Variant
For J = LBound(Arrays) To UBound(Arrays)
UBoundArr = UBoundArr + UBound(Arrays(J), 1)
Next J
ReDim arr(1 To UBoundArr, 1 To 1)
For J = LBound(Arrays) To UBound(Arrays)
For i = LBound(Arrays(J)) To UBound(Arrays(J))
arr(i + OldUBoundArray, 1) = Arrays(J)(i, 1)
Next i
OldUBoundArray = OldUBoundArray + UBound(Arrays(J), 1)
Next J
MergeArrays = arr
End Function
I was about to post this on the 16th, when right in front of my nose the post got deleted.我正要在 16 号发这个帖子,就在我眼前,帖子被删除了。 So I'm sorry there are no comments, it was a long time ago.所以很抱歉没有评论,这是很久以前的事了。
Option Explicit
Function getStackedArrays(ByVal FirstIndex As Long, _
ParamArray Arrays() As Variant) _
As Variant
' Define Lower-Upper Array.
Dim UB As Long: UB = UBound(Arrays)
Dim LU As Variant: ReDim LU(3)
Dim lub As Variant
Dim i As Long
For i = 0 To 3: ReDim lub(0 To UB): LU(i) = lub: Next i
' Populate Lower-Upper Array and calculate dimensions of Result Array.
Dim uCount As Long, uCurr As Long
Dim lMax As Long, lCurr As Long
For i = 0 To UB
If IsArray(Arrays(i)) Then
GoSub calcIsArray
Else
GoSub calcNotArray
End If
GoSub countnMax
Next i
If lMax = 0 Or uCount = 0 Then Exit Function
' Define Result Array.
Dim UB1 As Long: UB1 = FirstIndex + uCount - 1
Dim UB2 As Long: UB2 = FirstIndex + lMax - 1
Dim Result As Variant: ReDim Result(FirstIndex To UB1, FirstIndex To UB2)
' Populate Result Array.
Dim k As Long, l As Long, m As Long, n As Long
m = FirstIndex
For i = 0 To UB
If IsArray(Arrays(i)) Then
GoSub writeResult
End If
Next i
' Write Result Array to Function Result.
getStackedArrays = Result
Exit Function
' Subroutines
calcIsArray:
If LBound(Arrays(i)) <= UBound(Arrays(i)) Then
LU(0)(i) = LBound(Arrays(i)): LU(1)(i) = UBound(Arrays(i))
On Error Resume Next
LU(3)(i) = LBound(Arrays(i), 2): LU(3)(i) = UBound(Arrays(i), 2)
On Error GoTo 0
End If
Return
calcNotArray:
If Not IsEmpty(Arrays(i)) Then
ReDim lub(0): lub(0) = Arrays(i): Arrays(i) = lub
LU(0)(i) = 0: LU(1)(i) = 0
End If
Return
countnMax:
uCurr = LU(1)(i) - LU(0)(i) + 1: uCount = uCount + uCurr
On Error Resume Next
lCurr = LU(3)(i) - LU(2)(i) + 1
If lCurr > lMax Then lMax = lCurr
On Error GoTo 0
Return
writeResult:
If Not IsEmpty(LU(0)(i)) And Not IsEmpty(LU(2)(i)) Then ' 2D
For k = LU(0)(i) To LU(1)(i)
n = FirstIndex
For l = LU(2)(i) To LU(3)(i)
Result(m, n) = Arrays(i)(k, l)
n = n + 1
Next l
m = m + 1
Next k
Else ' 1D
For k = LU(0)(i) To LU(1)(i)
Result(m, FirstIndex) = Arrays(i)(k)
m = m + 1
Next k
End If
Return
End Function
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.