VBA从返回相同项目的数组中检索项目

Question

来自JS，我已经意识到在VBA中使用数组的方法非常少。因此，我创建了这一堆代码来查找2D数组中某些项的索引。这段代码的基本思想是浏览一堆打开的报告，将它们存储在一个数组中，然后根据它们与主报告中当前日期的匹配情况将它们拉出来。代码会运行，但它会反复对wkbArray 的第一项执行操作。当我尝试使用循环计数器来跟踪数组位置时，这不起作用。所以我创建了独立于那些的计数器，但这似乎也不起作用，因为它们一直保持为零。任何关于更好地跟踪2D阵列索引的想法都非常受欢迎。我不希望任何人通过所有这些代码，我只是将其全部包含在内，以便您可以看到我试图用来导航这些数组的逻辑。

Private Sub CommandButton1_Click()

Dim wkb As Workbook
Dim lastRow As Integer
Dim lastColumn As Integer
Dim i, t, j, z, r, k, w, f, u, e, d, v, n, p, b, aa As Integer
Dim yesCount As Integer
Dim finalArrayCount As Integer
Dim lastDBRow As Integer
Dim lastMacroRow As Long
Dim verylastDBRow As Integer
Dim bookName As String
Dim bookDate As String
Dim dateString As String
Dim activePaste As String
Dim matchDate As String
Dim startColumn As Long
startColumn = (Application.ActiveWorkbook.Sheets("Database(CU's)").Cells(3, Columns.Count).End(xlToLeft).Column) + 1
Dim bookCount As Integer
bookCount = Application.Workbooks.Count - 2
Dim wkbArray() As String
Dim duplicateArray() As Variant
Dim finalArray() As Variant
ReDim wkbArray((bookCount - 1), 1) As String

'Loop through each workbook, store book name and date from X2 in a 2d array'

Application.ActiveWorkbook.Sheets("macroPaste").Visible = True

i = 0
For Each wkb In Workbooks
    If Left(wkb.Name, 15) = "CP_Inventory_By" Then

        dateString = wkb.ActiveSheet.Range("X2").Value
        bookName = wkb.Name
        bookDate = Left(dateString, 5)

        'Add book name and date to array'

        wkbArray(i, 0) = bookName
        wkbArray(i, 1) = bookDate
        i = i + 1
    Else
    End If
Next wkb



'create loop to specify number of times to run paste operation'

For t = 1 To bookCount
    matchDate = Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("Database(CU's)").Cells(1, startColumn).Value

        'Find book name based on match date'
        d = 0
        n = 0
        For j = 0 To (bookCount - 1)
            If wkbArray(d, 1) = matchDate Then
            n = n + d
            End If
            d = d + 1
        Next j

        activePaste = wkbArray(n, 0)
        With Workbooks(activePaste).Sheets("CP_Inventory_By_Run_Date_Email")
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        End With

        'Set macroPaste Range equal to activePaste range, filter criteria.'

        Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("macroPaste").Range(Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("macroPaste").Cells(1, 1), Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("macroPaste").Cells(lastRow, 24)).Value = Workbooks(activePaste).Sheets("CP_Inventory_By_Run_Date_Email").Range(Workbooks(activePaste).Sheets("CP_Inventory_By_Run_Date_Email").Cells(1, 1), Workbooks(activePaste).Sheets("CP_Inventory_By_Run_Date_Email").Cells(lastRow, 24)).Value

        With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("macroPaste")
            lastMacroRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range(.Cells(1, 1), .Cells(lastMacroRow, 24)).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("AA1:AA12"), Unique:=False
            .UsedRange.Copy
        End With

        'Paste in daily paste sheet,

        With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("Paste Daily Data")
            .Range("E1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            currentLastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
            yesCount = Application.WorksheetFunction.CountIf(.Range(.Cells(2, 3), .Cells(currentLastRow, 3)), "Yes")
        End With



        'Create Array of "YES Database Items'
        If yesCount > 0 Then
            With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("Paste Daily Data")

                ReDim duplicateArray(yesCount, 2) As Variant
                r = 0

                For z = 2 To currentLastRow
                    If .Cells(z, 3).Value = "Yes" Then
                        duplicateArray(r, 0) = .Cells(z, 5).Value
                        duplicateArray(r, 1) = .Cells(z, 6).Value
                        duplicateArray(r, 2) = .Cells(z, 9).Value
                        r = r + 1
                    Else
                    End If
                Next z
            End With

            'Create final array with unique YES items'
            ReDim finalArray(yesCount, 2) As Variant
            finalArrayCount = 0
            k = 0
            f = 0
            'Figure our how many times to loop through duplicate array'
            p = 0
            For k = 0 To yesCount
                'Figure out if the value is already in the final array'
                v = 0
                aa = 0
                For f = 0 To yesCount
                    If finalArray(aa, 1) = duplicateArray(p, 1) Then
                    v = v + 1
                    End If
                    aa = aa + 1
                Next f
                'if the value isn't in the final array, then add it. Otherwise, next k
                If v = 1 Then
                    finalArray(p, 1) = duplicateArray(p, 1)
                    finalArray(p, 0) = duplicateArray(p, 0)
                    finalArray(p, 2) = duplicateArray(p, 2)
                    finalArrayCount = finalArrayCount + 1
                    p = p + 1
                End If

            Next k

            'Add new values from finalArray to bottom of DatabaseCU sheet'
            e = 0
            b = 0
            With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("Database(CU's)")
                lastDBRow = (.Cells(.Rows.Count, "D").End(xlUp).Row) + 1
                    For e = 0 To finalArrayCount - 1
                        .Cells(lastDBRow, 2).Value = finalArray(b, 0)
                        .Cells(lastDBRow, 3).Value = finalArray(b, 1)
                        .Cells(lastDBRow, 4).Value = finalArray(b, 2)
                        lastDBRow = lastDBRow + 1
                        b = b + 1
                    Next e
            End With
        End If

        'fill down formula and move to next sheet'


        With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("Database(CU's)")
            verylastDBRow = .Cells(.Rows.Count, "D").End(xlUp).Row
            .Range(.Cells(2, startColumn), .Cells(2, startColumn)).AutoFill Destination:=.Range(.Cells(2, startColumn), .Cells(verylastDBRow, startColumn)), Type:=xlFillDefault
            .Range(.Cells(2, startColumn), .Cells(verylastDBRow, startColumn)).Copy
            .Range(.Cells(2, startColumn), .Cells(verylastDBRow, startColumn)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End With

        'Clear daily paste
        With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("Paste Daily Data")
            .Range(Cells(2, 5), Cells(currentLastRow, 28)).Clear
        End With

        'clear macro paste
        With Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("macroPaste")
            .Range(.Cells(1, 1), .Cells(lastMacroRow, 24)).Clear
            On Error Resume Next
            .ShowAllData
            On Error GoTo 0
        End With

        'Erase Arrays
        Erase finalArray, duplicateArray

        startColumn = startColumn + 1
Next t

Workbooks("CP Inventory Metrics with Pallets new.xlsm").Sheets("macroPaste").Visible = False
End Sub

Answer 1

Javascript数组函数可通过JScript插件在Excel VBA中使用。

我指导你阅读这篇文章。

In Excel VBA on Windows, for parsed JSON variables what is this JScriptTypeInfo anyway?

向下滚动代码的最低部分。

Answer 2

您需要退出j循环，否则它将始终以相同的值退出

'Find book name based on match date'
d = 0
n = 0
For j = 0 To (bookCount - 1)
    If wkbArray(d, 1) = matchDate Then
      n = n + d
      exit for 'here
    End If
    d = d + 1
Next j

'You will then pick up the nth workbook in
activePaste = wkbArray(n, 0)