简体   繁体   English

Excel VBA,将2组数据合并成一个数组,去掉空白行

[英]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

Stack Arrays堆栈 Arrays

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.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM