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

Question

来自JS，我已经意识到在VBA中使用数组的方法非常少。正因为如此，我创建了这一堆代码来查找二维数组中的某些项目的索引。这段代码的基本思想是通过一堆打开的报告，将它们存储在一个数组中，并根据它们与主报告中当前日期的匹配情况将它们取出。该代码运行，但它重复执行wkbArray的第一项操作，只有。当我试图使用循环计数器来跟踪阵列位置时，这不起作用。所以我创建了独立于这些计数器的计数器，但这似乎也不奏效，因为它们始终保持为零。任何更好的方法来跟踪二维数组的索引的想法是非常赞赏。我不希望任何人通过所有这些代码，我只是将它全部包括在内，以便您可以看到我试图用来导航这些数组的逻辑。

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数组函数在Excel VBA中通过JScript插件提供。

我指引您阅读本文。

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)