You are here:---Rispondi a: [RISOLTO] Riassumere scadenze in foglio di lavoro
Rispondi a: [RISOLTO] Riassumere scadenze in foglio di lavoro2018-11-20T21:59:49+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Riassumere scadenze in foglio di lavoro Rispondi a: [RISOLTO] Riassumere scadenze in foglio di lavoro

sidsid
Moderatore
    Post totali: 718

    Non c’entra nulla con il file che avevo io :-(
    Prova questo

    Sub SCADUTI()
    
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim DB As Variant, Matrix() As Variant
    Dim j As Long, nIncr As Long
    
    Set WS1 = Sheets("DB Doc")
    Set WS2 = Sheets("In scadenza")
    
    DB = WS1.Range("A2:K" & WS1.Range("K" & Rows.Count).End(xlUp).Row).Value2
    WS2.Range("B:C").NumberFormat = "dd/mm/yyyy"
    For j = LBound(DB) To UBound(DB)
        Select Case True
            Case DB(j, 10) < Date And DB(j, 11) < Date
                nIncr = nIncr + 1
                ReDim Preserve Matrix(1 To 3, 1 To nIncr)
                Matrix(1, nIncr) = DB(j, 1)
                Matrix(2, nIncr) = DB(j, 10)
                Matrix(3, nIncr) = DB(j, 11)
            Case DB(j, 10) < Date
                nIncr = nIncr + 1
                ReDim Preserve Matrix(1 To 3, 1 To nIncr)
                Matrix(1, nIncr) = DB(j, 1)
                Matrix(2, nIncr) = DB(j, 10)
            Case DB(j, 11) < Date
                nIncr = nIncr + 1
                ReDim Preserve Matrix(1 To 3, 1 To nIncr)
                Matrix(1, nIncr) = DB(j, 1)
                Matrix(3, nIncr) = DB(j, 11)
            Case Else
        
        End Select
    Next j
    
    WS2.Range("A2:C" & Rows.Count).ClearContents
    
    If nIncr > 0 Then
        WS2.Range("A2:C" & nIncr + 1).Value = Application.Transpose(Matrix)
    End If
    
    Set WS1 = Nothing
    Set WS2 = Nothing
    
    End Sub

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi