You are here:--[RISOLTO] Riassumere scadenze in foglio di lavoro
[RISOLTO] Riassumere scadenze in foglio di lavoro 2018-11-21T14:34:02+00:00

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

  • Autore
    Articoli
  • bg66bg66
    Partecipante
      Post totali: 31
      #7299 |

      Buonasera,
      vorrei che all’apertura del file, le date scadute (colonna J) nel foglio di lavoro “DB doc” fossero riassunte nel foglio “Scaduto”.

      Grazie per l’aiuto.

      href=”https://www.dropbox.com/s/bom2du7rbshdoee/GestScadenze%20VForum.xlsm?dl=0″

      • Questo argomento è stato modificato 3 settimane, 1 giorno fa da bg66 bg66.
      • Questo argomento è stato modificato 2 settimane, 5 giorni fa da sid sid.
    • sidsid
      Moderatore
        Post totali: 502

        Un esempio da mettere in un modulo standard

        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:J" & WS1.Range("J" & Rows.Count).End(xlUp).Row).Value2
        
        For j = LBound(DB) To UBound(DB)
            If DB(j, 10) < Date Then
                nIncr = nIncr + 1
                ReDim Preserve Matrix(1 To 2, 1 To nIncr)
                Matrix(1, nIncr) = DB(j, 1)
                Matrix(2, nIncr) = CDate(DB(j, 10))
            End If
        Next j
        WS2.Range("A2:B" & Rows.Count).ClearContents
        
        If nIncr > 0 Then
            WS2.Range("A2:B" & nIncr + 1).Value = Application.Transpose(Matrix)
        End If
        
        Set WS1 = Nothing
        Set WS2 = Nothing
        
        End Sub
      • bg66bg66
        Partecipante
          Post totali: 31

          Ciao Sid,
          grazie per il tuo intervento.
          In realtà volutamente non ho scritto/detto che i dati in scadenza erano 2 perchè volevo provare io a capire lo script per poi correggerlo….ma purtroppo non ci sono riuscito :

          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("J" & Rows.Count).End(xlUp).Row).Value2
          
          For j = LBound(DB) To UBound(DB)
              If DB(j, 10) < Date Then
                  nIncr = nIncr + 1
                  ReDim Preserve Matrix(1 To 2, 1 To nIncr)
                  Matrix(1, nIncr) = DB(j, 1)
                  Matrix(2, nIncr) = CDate(DB(j, 10))
              End If
          Next j
          
          For k = LBound(DB) To UBound(DB)
              If DB(k, 11) < Date Then
                  nIncr = nIncr + 1
                  ReDim Preserve Matrix(1 To 2, 1 To nIncr)
                  Matrix(1, nIncr) = DB(k, 1)
                  Matrix(2, nIncr) = CDate(DB(k, 11))
              End If
          Next k
          WS2.Range("A2:C" & Rows.Count).ClearContents
          
          If nIncr > 0 Then
              WS2.Range("A2:B" & nIncr + 1).Value = Application.Transpose(Matrix)
          End If
          
          Set WS1 = Nothing
          Set WS2 = Nothing
          
          End Sub

          Il risultato ottenuto non è quello atteso:

          Attendo tue per capire l’errore….e mi mette anche le altre date all’americana..
          https://www.dropbox.com/s/mglovtkaxbrkcy0/GestScadenze%20VF%20bySid.xlsm?dl=0

          • Questa risposta è stata modificata 3 settimane fa da bg66 bg66.
          • Questa risposta è stata modificata 3 settimane fa da bg66 bg66.
          • Questa risposta è stata modificata 3 settimane fa da bg66 bg66.
        • sidsid
          Moderatore
            Post totali: 502

            Prova così

            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:J" & WS1.Range("J" & Rows.Count).End(xlUp).Row).Value2
            WS2.Range("B:B").NumberFormat = "dd/mm/yyyy"
            For j = LBound(DB) To UBound(DB)
                If DB(j, 10) < Date Then
                    nIncr = nIncr + 1
                    ReDim Preserve Matrix(1 To 2, 1 To nIncr)
                    Matrix(1, nIncr) = DB(j, 1)
                    Matrix(2, nIncr) = DB(j, 10)
                End If
            Next j
            WS2.Range("A2:B" & Rows.Count).ClearContents
            
            If nIncr > 0 Then
                WS2.Range("A2:B" & nIncr + 1).Value = Application.Transpose(Matrix)
            End If
            
            Set WS1 = Nothing
            Set WS2 = Nothing
            
            End Sub
          • bg66bg66
            Partecipante
              Post totali: 31

              Ciao Sid,
              il risultato ottenuto è diverso dal dato atteso :

              Grazie se puoi.

              Gene

              • Questa risposta è stata modificata 2 settimane, 6 giorni fa da bg66 bg66.
            • sidsid
              Moderatore
                Post totali: 502

                Non capisco se tu vuoi entrambe le date della scadenza; sia della CCIAA sia scadenza 2

              • sidsid
                Moderatore
                  Post totali: 502

                  Quale date devo verificare, colonna F o colonna J? Oppure entrambe?
                  Il file che hai postato non è lo stesso che vedo nell’immagine.
                  nell’immagine i nomi sono Alfa setx, in quello che ho io il nome è Disneyx

                • bg66bg66
                  Partecipante
                    Post totali: 31

                    Ciao Sid,
                    allego l’ultima versione su cui faccio le prove.
                    https://www.dropbox.com/s/mglovtkaxbrkcy0/GestScadenze%20VF%20bySid.xlsm?dl=0

                    L’obiettivo sarebbe quello di seguito schematizzato:

                    Grazie ancora.

                  • sidsid
                    Moderatore
                      Post totali: 502

                      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
                    • bg66bg66
                      Partecipante
                        Post totali: 31

                        [RISOLTO]
                        Ciao Sid,
                        è perfetta.
                        Scusami ancora per il refuso.

                        Grazie e alla prossima.
                        Gene

                      La discussione ‘[RISOLTO] Riassumere scadenze in foglio di lavoro’ è chiusa a nuove risposte.

                      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