arrays - 将项目添加到数组而不是替换
问题描述
我有一些代码使用数组从一个工作表（成本数据）获取数据，并以并排比较格式将其复制到另一个工作表（比较工具）。我得到了一切工作，只是发现在某些情况下，成本数据工作表上有多行数据符合标准。当这些数据行分配给我的 outarr 数组时，它会覆盖其中的内容而不是添加到其中。
我尝试使用 ReDim Preserve；但是，我仍然遇到错误。有什么建议么？
Sub Compare_Projects_Arrays()
Dim Toolary As Variant, Data_ary As Variant, PrjTitle_ary As Variant, CurrentAry As Variant, outarr As Variant
Dim r As Long, nr As Long, x As Long, c As Long, CurrentCostCod As Long
Dim Cl As Range
Dim Project1 As String, Project2 As String, Project3 As String, Project4 As String, Project5 As String, Project6 As String, Project7 As String, Project8 As String
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Compare Tool").ShowAllData
Sheets("Cost Data").ShowAllData
Sheets("Compare Tool").Range("Clear_Cells").SpecialCells(xlConstants).ClearContents
Sheets("Compare Tool").Range("AD15:AD16,AD19,AQ15:AD16,AQ19,BD15:BD16,BD19,BQ15:BQ16,BQ19,CD15:CD16, CD19,CQ15:CQ16, CQ19,DD15:DD16, DD19,DQ15:DQ16,DQ19").ClearContents
Sheets("Compare Tool").Range("X23:DW24").ClearContents
On Error GoTo 0
With Sheets("Setup Page")
Typology = .Range("L18")
Project1 = .Range("U11").Value
Project2 = .Range("U12").Value
Project3 = .Range("U13").Value
Project4 = .Range("U14").Value
Project5 = .Range("U15").Value
Project6 = .Range("U16").Value
Project7 = .Range("U17").Value
Project8 = .Range("U18").Value
End With
With Sheets("Compare Tool")
Set SearchRangeTool = .Range("E:E").Find(What:="Last Row")
LastRowTool = SearchRangeTool.Row
If Project1 <> "" Then
.Range("X23") = Project1
.Range("X24") = "Typology: " & Typology
End If
If Project2 <> "" Then
.Range("AK23") = Project2
.Range("AK24") = "Typology: " & Typology
End If
If Project3 <> "" Then
.Range("AX23") = Project3
.Range("AX24") = "Typology: " & Typology
End If
If Project4 <> "" Then
.Range("BK23") = Project4
.Range("BK24") = "Typology: " & Typology
End If
If Project5 <> "" Then
.Range("BX23") = Project5
.Range("BX24") = "Typology: " & Typology
End If
If Project6 <> "" Then
.Range("CK23") = Project6
.Range("CK24") = "Typology: " & Typology
End If
If Project7 <> "" Then
.Range("CX23") = Project7
.Range("CX24") = "Typology: " & Typology
End If
If Project8 <> "" Then
.Range("DK23") = Project8
.Range("DK24") = "Typology: " & Typology
End If
End With
'Put data into the arrarys (Toolary & Data_ary)
Data_ary = Sheets("Cost Data").Range("A1").CurrentRegion.Value2
With Sheets("Compare Tool")
Toolary = .Range("A28:DV" & .Range("U" & Rows.Count).End(xlUp).Row).Value2
End With
'Project 1
'Check if Project field is blank
If Sheets("Setup Page").Range("U11") = "" Then GoTo Project2
With Sheets("Cost Data")
FirstRowDB = .Range("A:A").Find(What:=Project1, LookIn:=xlValues, SearchDirection:=xlNext).Row 'xlNext starts from top
GSFPrj = .Cells(FirstRowDB, 13)
GSFTypology = .Cells(FirstRowDB, 18)
End With
'Copy the GSF area & Total Project cost and paste into the top of the "Compare Tool" tab
Sheets("Prj Info").Select
FindPrj = Application.Match(Project1, Range("A:A"), 0)
Total_Prj_Cost = Sheets("Prj Info").Cells(FindPrj, 16)
Sheets("Compare Tool").Range("AD19") = GSFTypology
Sheets("Compare Tool").Range("AD16") = GSFPrj
Sheets("Compare Tool").Range("AD15") = Total_Prj_Cost
lastrow = UBound(Toolary)
outarr = Worksheets("Compare Tool").Range("X28:AI" & lastrow)
'The following will put the formulas from the subtotals lines into the "toolfrom" array and then put it into the "outarr" array
With Sheets("Compare Tool")
toolfrom = .Range("X28:AI" & lastrow).formula
End With
For i = 1 To UBound(outarr, 1)
For j = 1 To UBound(outarr, 2)
If Left(toolfrom(i, j), 1) = "=" Then 'erroring out at i=1 and j=10
outarr(i, j) = toolfrom(i, j)
End If
Next j
Next i
For r = 1 To lastrow
If Toolary(r, 5) = "Single" Or Toolary(r, 5) = "T2 Head" Then
CurrentCostCode = Toolary(r, 21)
CurrentT0 = Toolary(r, 9)
ReDim Preserve outarr(r) 'This is where the error happens
For x = 2 To UBound(Data_ary)
If Data_ary(x, 1) = Project1 And Data_ary(x, 34) = CurrentCostCode And Data_ary(x, 22) = CurrentT0 And Data_ary(x, 17) = Typology Then
outarr(r, 1) = Data_ary(x, 37) 'This is where the data is getting overwritten
outarr(r, 2) = Data_ary(x, 38) 'This is where the data is getting overwritten
outarr(r, 3) = Data_ary(x, 39) 'This is where the data is getting overwritten
outarr(r, 4) = Data_ary(x, 40) 'This is where the data is getting overwritten
outarr(r, 5) = Data_ary(x, 41) 'This is where the data is getting overwritten
outarr(r, 6) = Data_ary(x, 42) 'This is where the data is getting overwritten
outarr(r, 7) = Data_ary(x, 43) 'This is where the data is getting overwritten
If Data_ary(x, 44) <> "" Then
outarr(r, 8) = Data_ary(x, 44) 'This is where the data is getting overwritten
outarr(r, 9) = Data_ary(x, 45) 'This is where the data is getting overwritten
End If
End If
Next x
End If
Next r
Worksheets("Compare Tool").Range("X28:AF" & lastrow) = outarr
'Project 2
Project2:
Application.ScreenUpdating = True
End Sub