Copia-Incolla al sopraggiungere di un orario.

Question

Ciao,

ho la seguente tabella con dati scaricati dal web:

Nel momento in cui l'orario attuale corrisponde all'orario presente nella colonna M, i dati presenti nella stessa riga dell'intervallo H : O vengono cancellati. (Adesso si vedono perché ho bloccato l'aggiornamento dei dati online).

Domanda,

è possibile automatizzare il copia e incolla dell'intervallo A : O incollandolo partendo dalla colonna Q nel momento in cui manca, ad esempio, un minuto all'orario attuale?

Cioè,

prendiamo la cella M83 con data e orario 14-01 01:00

il copia e incolla dovrebbe scattare nel momento in cui la data e l'orario attuale corrispondono alle 14-01 00:59 cioè un minuto in meno rispetto all'orario presente nella cella M83.

Altro esempio:

prendiamo la cella M84 con data e orario 14-01 01:45

il copia e incolla dovrebbe scattare nel momento in cui la data e l'orario corrispondono alle 14-01 01:44 cioè un minuto in meno rispetto all'orario presente nella cella M84.

Vladimiro

Answer 1

Ciao Vladimiro,

Ciao Norman,

questa volta la vedo dura!

Modificando nel mio file solo questa parte di codice:

For i = 1 To UB

If Not IsNumeric(Left(arrIn(i, 13), 1)) Then

Exit For

End If

dValue = DateValue(arrIn(i, 13)) + TimeValue(arrIn(i, 13))

If dValue > Now() Then

Exit For

End If

iCtr = iCtr + 1

Next i

non succede nulla, nel senso che non mi incolla nessun dato.

Nel modo in cui viene scritto il codice, la tabella non verrà aggiornata ei dati scaduti non verranno riportati nelle colonne Q:AB fino alla scadenza del primo intervallo di 15 minuti.

Per eseguire queste operazioni all'apertura del file, nel modulo Questa_cartella_di_lavore, sostituire la procedura WSorkbook_Open con la seguente versione:

'--------->>

Cartella di lavoro secondaria privata_Open()

 Call Aggiorna\_Tabella0

Fine Sub

'--------->>

Come prima, salva, chiudi e riapri il file.

Mentre, aprendo il tuo file:

Potresti scaricare il mio file di prova Vladimiro20220116.xlsm.

mi dà il seguente errore:

forse dipende dall'errore dell'aggiornamento della tabella?

Non riesco a replicare questo problema: da me il codice funziona nel modo previsto, aggiornandi la tabella ogni 15 munti e riportando i dati scaduti nelle colonne Q:AB

Ho provato pure ad implementare il copia-incolla direttamente nel modulo, ma mi dà il seguente errore:

Potrei replicare questo errore solo se dovessi eseguire manualmente la procedura Copia_Dati_Scaduti, non avendo precedentemente eseguito la procedura Aggiorna_Tabella0; quest'ultima procedura dimensiona e definisce la variabile di livello del modulo oTabella.

Infatti il codice è progettato per funzionare automaticamente ogni 15 minuti, senza alcun intervento da parte tua e, più esplicitamente, senza l'esecuzione manuale di nessuna delle procedure.

Quindi, suggerirei che, oltre ad effettuare la modifica del codice descritta sopra, mi mandi il tuo file. In questo modo non posso solo testare il codice utilizzando la tua disposizione dei dati reali, ma posso assicurarmi che il codice sia correttamente incorporato e funzioni, come è la mia esperienza, senza alcun problema.

Ho aggiornato il mio file di prova Vladimiro20220116.xlsm

===

Regards,

Norman

Answer 2

Ciao Norman,

questa volta la vedo dura!

Modificando nel mio file solo questa parte di codice:

For i = 1 To UB

If Not IsNumeric(Left(arrIn(i, 13), 1)) Then

Exit For

End If

dValue = DateValue(arrIn(i, 13)) + TimeValue(arrIn(i, 13))

If dValue > Now() Then

Exit For

End If

iCtr = iCtr + 1

Next i

non succede nulla, nel senso che non mi incolla nessun dato.

Mentre, aprendo il tuo file:

Potresti scaricare il mio file di prova Vladimiro20220116.xlsm.

mi dà il seguente errore:

forse dipende dall'errore dell'aggiornamento della tabella?

Ho provato pure ad implementare il copia-incolla direttamente nel modulo, ma mi dà il seguente errore:

Vladimiro

Answer 3

Ciao Vladimiro,

ho scaricato il file e naturalmente funziona.

Solo che mi servono delle informazioni.

La colonna B del tuo file dove si trova l'orario, a me si trova in M:

Forse è questo il motivo che quando aggiorno la tabella mi dà errore?

Nel mio codice, sostituisci

    For i = 1 To UB

    dValue = DateValue(arrIn(i, 2)) + TimeValue(arrIn(i, 2))

    If dValue > Now() Then

        Exit For

    End If

    iCtr = iCtr + 1

    Next i

con:

For i = 1 To UB 

    **If Not IsNumeric(Left(arrIn(i, 13), 1)) Then** 

        **Exit For** 

    **End If** 

    dValue = DateValue(arrIn(i, **13**)) + TimeValue(arrIn(i, **13**)) 

    If dValue > Now() Then 

        Exit For 

    End If 

    iCtr = iCtr + 1 

Next i

Una volta risolto il problema, si dovrebbe fare in modo di far scattare il copia-incolla un minuto prima dell'orario scritto nella cella e automatizzare il tutto senza bisogno di aggiornare manualmente in quanto l'opzione di aggiornamento già ce l'abbiamo:

Annulla l'aggiornamento automatico della tabella e poi, nel modulo codice standard di interesse, sostituisci il codice precedente con:

'========>>

Option Explicit

Dim oSH As Worksheet

Dim sTabella As String

Dim oTabella As ListObject

Public RunWhen As Double

Public Const cRunIntervalSeconds =900  '\ 15 minuti '<<=== Modifica

Public Const cRunWhat = "Aggiorna_Tabella0"  

Public Const sFoglio As String = "Merge1" '<<=== Modifica

'-------->>

Public Sub StartTimer()

    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)

    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _

        Schedule:=True

End Sub

'-------->>

Public Sub StopTimer()

    On Error Resume Next

    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _

        Schedule:=False

End Sub

'-------->>

Public Sub Aggiorna_Tabella0()

    Set oSH = ThisWorkbook.Sheets(sFoglio)

    With oSH

        sTabella = .Range("A1").ListObject.Name

        Set oTabella = .ListObjects(sTabella)

    End With

    Call Copia_Dati_Scaduti

    oTabella.QueryTable.Refresh BackgroundQuery:=True 'False

End Sub

'-------->>

Public Sub Copia_Dati_Scaduti()

    Dim srcRng As Range, destRng As Range

    Dim arrIn As Variant

    Dim dValue As Double

    Dim sTabella As String

    Dim i As Long, iCtr As Long, LRow As Long

    Dim UB As Long, UB2 As Long

    Const sFoglio As String = "Merge1"

    Const sColonna_Destinazione As String = "Q"

    With oSH

        Set srcRng = oTabella.DataBodyRange

        LRow = LastRow(oSH, .Columns(sColonna_Destinazione))

        Set destRng = .Columns(sColonna_Destinazione).Cells(LRow + 1)

    End With

    arrIn = srcRng.Value2

    UB = UBound(arrIn)

    UB2 = UBound(arrIn, 2)

    For i = 1 To UB

        If Not IsNumeric(Left(arrIn(i, 13), 1)) Then

            Exit For

        End If

        dValue = DateValue(arrIn(i, 13)) + TimeValue(arrIn(i, 13))

        If dValue > Now() Then

            Exit For

        End If

        iCtr = iCtr + 1

    Next i

    If CBool(iCtr) Then

        destRng.Resize(iCtr, UB2).Value = arrIn

    End If

    Call StartTimer

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

    Optional Rng As Range, _

    Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

        After:=Rng.Cells(1), _

        Lookat:=xlPart, _

        LookIn:=xlFormulas, _

        SearchOrder:=xlByRows, _

        SearchDirection:=xlPrevious, _

        MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<========

Nel modulo di codice dell'oggetto Questa_cartella_di_lavoro, incolla il seguente codice:

'========>>

Option Explicit

'-------->>

Private Sub Workbook_Open()

Call StartTimer 

End Sub

'-------->>

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Call StopTimer 

End Sub

'<<========

Salva, chiudi e riapri il tuo file.

Potresti scaricare il mio file di prova Vladimiro20220116.xlsm.

Va notato che, in questo file di prova, la mia tabella include la data/ora nella colonna 2.

===

Regards,

Norman

Answer 4

Ciao Vladimiro,

ho la seguente tabella con dati scaricati dal web:

Nel momento in cui l'orario attuale corrisponde all'orario presente nella colonna M, i dati presenti nella stessa riga dell'intervallo H : O vengono cancellati. (Adesso si vedono perché ho bloccato l'aggiornamento dei dati online).

Domanda,

è possibile automatizzare il copia e incolla dell'intervallo A : O incollandolo partendo dalla colonna Q nel momento in cui manca, ad esempio, un minuto all'orario attuale?

Cioè,

prendiamo la cella M83 con data e orario 14-01 01:00

il copia e incolla dovrebbe scattare nel momento in cui la data e l'orario attuale corrispondono alle 14-01 00:59 cioè un minuto in meno rispetto all'orario presente nella cella M83.

Altro esempio:

prendiamo la cella M84 con data e orario 14-01 01:45

il copia e incolla dovrebbe scattare nel momento in cui la data e l'orario corrispondono alle 14-01 01:44 cioè un minuto in meno rispetto all'orario presente nella cella M84.

Vladimiro

Supponiamo che tu stia aggiornando la tabella via VBA con una procedura del genere:

'========>>

Public Sub Aggiorna_Tabella0()

Call Copia_Dati_Scaditi

ThisWorkbook.RefreshAll

End Sub

'<<========

In un modulo standard, prova a sostituire quella procedura con qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub Aggiorna_Tabella0()

    Call Copia_Dati_Scaditi

    ThisWorkbook.RefreshAll

End Sub

'-------->>

Public Sub Copia_Dati_Scaduti()

    Dim SH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim oTabella As ListObject

    Dim arrIn As Variant

    Dim dValue As Double

    Dim sTabella As String

    Dim i As Long, iCtr As Long, LRow As Long

    Dim UB As Long, UB2 As Long

    Const sFoglio As String = "Merge1"

    Const sColonna_Destinazione As String = "Q"

    Set SH = ThisWorkbook.Sheets(sFoglio)

    With SH

        sTabella = SH.Range("H1").ListObject.Name

        Set oTabella = .ListObjects(sTabella)

        Set srcRng = oTabella.DataBodyRange

        LRow = LastRow(SH, .Columns(sColonna_Destinazione))

        Set destRng = .Columns(sColonna_Destinazione).Cells(LRow + 1)

    End With

    arrIn = srcRng.Value2

    UB = UBound(arrIn)

    UB2 = UBound(arrIn, 2)

    

    For i = 1 To UB

    dValue = DateValue(arrIn(i, 2)) + TimeValue(arrIn(i, 2))

    If dValue > Now() Then

        Exit For

    End If

    iCtr = iCtr + 1

    Next i

    

  If CBool(iCtr) Then

   destRng.Resize(iCtr, UB2).Value = arrIn

  End If

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

    Optional Rng As Range, _

    Optional minRow As Long = 1)

    

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

        After:=Rng.Cells(1), _

        Lookat:=xlPart, _

        LookIn:=xlFormulas, _

        SearchOrder:=xlByRows, _

        SearchDirection:=xlPrevious, _

        MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<========

Potresti scaricare il mio file di prova Vladimiro20220114.xlsm

===

Regards,

Norman

Ciao Norman,

ho scaricato il file e naturalmente funziona.

Solo che mi servono delle informazioni.

La colonna B del tuo file dove si trova l'orario, a me si trova in M:

Forse è questo il motivo che quando aggiorno la tabella mi dà errore?

Una volta risolto il problema, si dovrebbe fare in modo di far scattare il copia-incolla un minuto prima dell'orario scritto nella cella e automatizzare il tutto senza bisogno di aggiornare manualmente in quanto l'opzione di aggiornamento già ce l'abbiamo:

Vladimiro

Answer 5

Ciao Vladimiro,

ho la seguente tabella con dati scaricati dal web:

Nel momento in cui l'orario attuale corrisponde all'orario presente nella colonna M, i dati presenti nella stessa riga dell'intervallo H : O vengono cancellati. (Adesso si vedono perché ho bloccato l'aggiornamento dei dati online).

Domanda,

è possibile automatizzare il copia e incolla dell'intervallo A : O incollandolo partendo dalla colonna Q nel momento in cui manca, ad esempio, un minuto all'orario attuale?

Cioè,

prendiamo la cella M83 con data e orario 14-01 01:00

il copia e incolla dovrebbe scattare nel momento in cui la data e l'orario attuale corrispondono alle 14-01 00:59 cioè un minuto in meno rispetto all'orario presente nella cella M83.

Altro esempio:

prendiamo la cella M84 con data e orario 14-01 01:45

il copia e incolla dovrebbe scattare nel momento in cui la data e l'orario corrispondono alle 14-01 01:44 cioè un minuto in meno rispetto all'orario presente nella cella M84.

Vladimiro

Supponiamo che tu stia aggiornando la tabella via VBA con una procedura del genere:

'========>>

Public Sub Aggiorna_Tabella0()

Call Copia\_Dati\_Scaditi 

ThisWorkbook.RefreshAll 

End Sub

'<<========

In un modulo standard, prova a sostituire quella procedura con qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub Aggiorna_Tabella0()

    Call Copia_Dati_Scaditi

    ThisWorkbook.RefreshAll

End Sub

'-------->>

Public Sub Copia_Dati_Scaduti()

    Dim SH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim oTabella As ListObject

    Dim arrIn As Variant

    Dim dValue As Double

    Dim sTabella As String

    Dim i As Long, iCtr As Long, LRow As Long

    Dim UB As Long, UB2 As Long

    Const sFoglio As String = "Merge1"

    Const sColonna_Destinazione As String = "Q"

    Set SH = ThisWorkbook.Sheets(sFoglio)

    With SH

        sTabella = SH.Range("H1").ListObject.Name

        Set oTabella = .ListObjects(sTabella)

        Set srcRng = oTabella.DataBodyRange

        LRow = LastRow(SH, .Columns(sColonna_Destinazione))

        Set destRng = .Columns(sColonna_Destinazione).Cells(LRow + 1)

    End With

    arrIn = srcRng.Value2

    UB = UBound(arrIn)

    UB2 = UBound(arrIn, 2)

    For i = 1 To UB

    dValue = DateValue(arrIn(i, 2)) + TimeValue(arrIn(i, 2))

    If dValue > Now() Then

        Exit For

    End If

    iCtr = iCtr + 1

    Next i

  If CBool(iCtr) Then

   destRng.Resize(iCtr, UB2).Value = arrIn

  End If

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

    Optional Rng As Range, _

    Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

        After:=Rng.Cells(1), _

        Lookat:=xlPart, _

        LookIn:=xlFormulas, _

        SearchOrder:=xlByRows, _

        SearchDirection:=xlPrevious, _

        MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<========

Potresti scaricare il mio file di prova Vladimiro20220114.xlsm

===

Regards,

Norman