带有数组宏的奇怪维度

Question

所以我编写了这段代码，它应该产生两个数组，分别从单元格 I4 和 O4 开始。

Option Explicit

Sub QuartTransfer()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim cws As Worksheet: Set cws = wb.Worksheets("All Transaction Data")
    Dim dws As Worksheet: Set dws = wb.Worksheets("Quarterly Transfers")
    
    Dim srg As Range: Set srg = cws.Range("B2:V" & dws.Range("C1").Value)
    Dim Data As Variant: Data = srg.Value
    Dim Sale(), Pur() As Variant
    
    Application.ScreenUpdating = False
    
    Dim i, k, p As Long
    For i = 1 To UBound(Data, 1)
        If Data(i, 9) = "Intra L.E. Sale" Or Data(i, 9) = "Tax Free Exchange - Dis" Or Data(i, 9) = "InterCompany Sale IP2" Then
            k = k + 1
            ReDim Preserve Sale(6, 1 To k)
            Sale(1, k) = Data(i, 5)
            Sale(3, k) = Data(i, 1)
            Sale(4, k) = Data(i, 11)
            Sale(5, k) = Data(i, 13)
            Sale(6, k) = Data(i, 8)
        ElseIf Data(i, 9) = "Intra L.E. Purchase" Or Data(i, 9) = "Tax Free Exchange - Acq" Or Data(i, 9) = "InterCompany Pur IP2" Then
            p = p + 1
            ReDim Preserve Pur(7, 1 To p)
            Pur(1, p) = Data(i, 9)
            Pur(2, p) = Data(i, 5)
            Pur(4, p) = Data(i, 1)
            Pur(5, p) = Data(i, 11)
            Pur(6, p) = Data(i, 13)
            Pur(7, p) = Data(i, 8)
        End If
    Next i
    
    dws.Range("I4").Resize(k, 6).Value = Application.WorksheetFunction.Transpose(Sale)
    dws.Range("O4").Resize(p, 7).Value = Application.WorksheetFunction.Transpose(Pur)
    
    Application.ScreenUpdating = True

End Sub

问题是结果向右移动一列，最后一列数据丢失。我在这里缺少什么吗？请帮忙！

Answer 1

在循环中使用 Redim Preserve 非常昂贵且耗时。没有理由这样做。您已经限制了大小或输出。

另外你的问题是你假设数组从 1 开始但它从 0 开始。这就是你的列关闭的原因。

创建与输入行数相同的两个数组，然后在它们已满的地方发布。计数器 k 和 p 将跟踪它。

另外Dim i, k, p As Long 仅将k 声明为Long 其他为Variant

Option Explicit

Sub QuartTransfer()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim cws As Worksheet: Set cws = wb.Worksheets("All Transaction Data")
    Dim dws As Worksheet: Set dws = wb.Worksheets("Quarterly Transfers")
    
    Dim srg As Range: Set srg = cws.Range("B2:V" & dws.Range("C1").Value)
    Dim Data() As Variant: Data = srg.Value
    Dim Sale() As Variant
    ReDim Sale(1 To UBound(Data, 1), 1 To 6) As Variant
    
    Dim Pur() As Variant
    ReDim Pur(1 To UBound(Data, 1), 1 To 7) As Variant
    
    
    Dim i As Long, k As Long, p As Long
    For i = 1 To UBound(Data, 1)
        If Data(i, 9) = "Intra L.E. Sale" Or Data(i, 9) = "Tax Free Exchange - Dis" Or Data(i, 9) = "InterCompany Sale IP2" Then
            k = k + 1
            Sale(k, 1) = Data(i, 5)
            Sale(k, 3) = Data(i, 1)
            Sale(k, 4) = Data(i, 11)
            Sale(k, 5) = Data(i, 13)
            Sale(k, 6) = Data(i, 8)
        ElseIf Data(i, 9) = "Intra L.E. Purchase" Or Data(i, 9) = "Tax Free Exchange - Acq" Or Data(i, 9) = "InterCompany Pur IP2" Then
            p = p + 1
            Pur(p, 1) = Data(i, 9)
            Pur(p, 2) = Data(i, 5)
            Pur(p, 4) = Data(i, 1)
            Pur(p, 5) = Data(i, 11)
            Pur(p, 6) = Data(i, 13)
            Pur(p, 7) = Data(i, 8)
        End If
    Next i
    
    dws.Range("I4").Resize(k, 6).Value = Sale
    dws.Range("O4").Resize(p, 7).Value = Pur
    


End Sub