Question

我有这个很好的自动程序

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, L:L")) Is Nothing Then
    On Error GoTo Fìn
    Application.EnableEvents = False
    Dim i As Long, n As Long
    Dim arrmatrix As Variant
    ReDim arrmatrix(1 To 1, 1 To 1)
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, 12).Value = "Pi emitida" Then
            n = n + 1
            ReDim Preserve arrmatrix(1 To 1, 1 To n)
            arrmatrix(1, n) = Cells(i, 1).Value
        End If
    Next i
    With Worksheets("Inicio")
        .Range("G4:G" & Rows.Count).ClearContents
        .Range("G4").Resize(UBound(arrmatrix, 2), 1) =      Application.Transpose(arrmatrix)
    End With
End If
Fìn:
Application.EnableEvents = True
End Sub

我现在的问题是我想做同样的事情并在第一个列旁边的列中粘贴一个不同的数组，数组必须这样做但是如果达到了这些条件：

dim hoy as date
hoy=date
If Cells(j, 12).Value = "Pi emitida" Or Cells(j, 12).Value = "PI firmada" Or       Cells(j, 12).Value = "Carta credito L/c" Or Cells(j, 12).Value = "Con booking" And hoy - Cells(j, 12).Value >= 0

Answer 1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, n As Long, Dim j As Long, m As Long
    Dim arrmatrix() As Variant, Dim arrmatrix1() As Variant
 If Not Intersect(Target, Range("A:A, L:L")) Is Nothing Then
    ' On Error GoTo Fìn 'Commented to find out which line your error actually is - Uncomment once fixed
    Application.EnableEvents = False

    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, 12).Value = "Pi emitida" Then
            n = n + 1
            ReDim Preserve arrmatrix(1 To 1, 1 To n)
            arrmatrix(1, n) = Cells(i, 1).Value
        End If

        If (Cells(i, 12).Value = "Pi emitida" Or Cells(i, 12).Value = "PI firmada" Or Cells(i, 12).Value = "Carta credito L/c" Or Cells(i, 12).Value = "Con booking") and DateDiff(d, Cells(i, 17).Value, Today) > 0 Then
            m = m + 1
            ReDim Preserve arrmatrix1(1 To 1, 1 To m)
            arrmatrix1(1, m) = Cells(i, 1).Value
        End If
    Next i
    With Worksheets("Inicio")
        .Range("G4:G" & Rows.Count).ClearContents
        .Range("G4").Resize(UBound(arrmatrix, 2), 1) = Application.Transpose(arrmatrix)
        .Range("H4:H" & Rows.Count).ClearContents
        .Range("H4").Resize(UBound(arrmatrix1, 2), 1) = Application.Transpose(arrmatrix1)
    End With
End If

 Fìn:
Application.EnableEvents = True
End Sub

粘贴数组后，我想在第一个数组旁边粘贴一个新数组

1 个答案: