verifica contenuti e copia

Hai un problema con Excel?

Nuova discussione

verifica contenuti e copia
di bebo987 (utente non iscritto) data: 30/08/2017 14:15:44
Caro forum,

dovrei sistemare questa codice qua ma mi sono un po' incastrato: in pratica il codice deve trasferire tutte le righe di Expansion lookup alla fine di variations aggiungengo la data del trasferimento.

per questo ho tentato di impostare il loop e l'if statement in modo che analizzi tutti i record in expansion lookup e li aggiunga quando trova la riga libera in Variations mettendo nella colonna A la data della copia ( Sheets("key criteria").Activate
Set today = Sheets("key criteria").Range("b27")) per intenderci

Ho provato a fare qualche test ma alla fine ho fallito miseramente

Sub fillVariations()

    Dim today
    Dim origin_range As Range
    Dim dest_range As Range
    

    Application.ScreenUpdating = False
    bCalcMode = Application.CalculationState
    Application.Calculation = xlCalculationManual
    
    Sheets("key criteria").Activate
    Set today = Sheets("key criteria").Range("b27")
    
    Sheets("expansion lookups").Activate
    Set origin_range = Sheets("expansion lookups").Range("a2")
        
    Sheets("VARIATIONS").Activate
    Set dest_range = Sheets("variations").Range("a1")
    
    Do While origin_range.Offset(1, 0) <> ""
        Set origin_range = origin_range.Offset(0, 1)
        Set dest_range = dest_range.Offset(0, 1)
        
        If dest_range = "" Then
        
        dest_range.Offset(0, 0) = today 'today day in col A
        dest_range.Offset(0, 1) = origin_range.Offset(0, 0) 'QF seasonality
        dest_range.Offset(0, 2) = origin_range.Offset(0, 1) 'origin
        dest_range.Offset(0, 3) = origin_range.Offset(0, 2) 'class
        dest_range.Offset(0, 4) = origin_range.Offset(0, 3) 'destination
        dest_range.Offset(0, 5) = origin_range.Offset(0, 4) 'cxr
        dest_range.Offset(0, 6) = orgin_range.Offset(0, 5) 'aif
        
    End If
    Loop
    
    
    Application.Calculation = xlCalculationAutomatic
    Application.Calculation = bCalcMode
    Application.ScreenUpdating = True

End Sub

di toty (utente non iscritto) data: 31/08/2017 10:01:07
come si fa a testare il codice senza il file?
verifica contenuti e copia
di bebo987 (utente non iscritto) data: 31/08/2017 10:34:45
Allegato :) ho dovuto tagliare un po' per farcelo stare
di patel data: 31/08/2017 10:41:00
Non ho capito molto, sarebbe utile un esempio di risultato desiderato
verifica contenuti e copia
di bebo987 (utente non iscritto) data: 31/08/2017 11:04:23
Ciao Patel, grazie per l'interessamento.

Banalmente: quello che hai nel foglio che ora si chiama sheet 1 nornalmente starebbe in "Variations" ed e' il foglio destinazione.
La macro deve capire quando la riga e' libera e copiare dest_range che sarebbe il contenuto di Expansion Lookups con nella colonna A la data odierna ergo la data in cui la macro viene attivata.

fammi sapere se non mi sono spiegato.
intanto ho aggiornato un po' il codice

di patel data: 31/08/2017 12:49:55
prova questa impostando il formato data nella colonna A di variation

Sub fillVariations()
    Set today = Sheets("key criteria").Range("b27")
    LR = Sheets("VARIATIONS").Cells(Rows.Count, "B").End(xlUp).Row + 1
    Set r1 = Sheets("expansion lookups").Range("A2").CurrentRegion
    r1.Offset(1, 0).Resize(, 6).Copy Sheets("VARIATIONS").Cells(LR, 2)
    LRV = Sheets("VARIATIONS").Cells(Rows.Count, "B").End(xlUp).Row
    Sheets("VARIATIONS").Range("A" & LR & ":A" & LRV).Value = today

End Sub

di toty (utente non iscritto) data: 31/08/2017 13:10:49
All'ottima proposta di Patel inserisco un semplice copia incolla... se ho capito bene cosa vuoi ottenere...

Option Explicit
Sub fillVariations()
Dim UrEL As Long, UrV As Long

UrEL = Sheets("EXPANSION LOOKUPS").Range("A1").CurrentRegion.Rows.Count
UrV = Sheets("VARIATIONS").Range("A1").CurrentRegion.Rows.Count + 1
Sheets("VARIATIONS").Range("A" & UrV & ":" & "A" & UrV + UrEL - 2) = Date
Sheets("EXPANSION LOOKUPS").Range("A2:F" & UrEL).Copy Destination:=Worksheets("VARIATIONS").Range("B" & UrV)

End Sub

verifica contenuti e copia
di albe.btz (utente non iscritto) data: 04/10/2017 16:34:42
Ciao Patel,
c'e' un problema con questa sub e' una sciocchezza: nella tabella Expansion Lookups una colonna e' fatta di funzioni quindi quando va ad inserire i valori in Variations poi risulta tutto 0.

anziche sostituire le celle con le selezioni non si potrebbe incollare i valori?

Sub fillVariations()
    Set today = Sheets("key criteria").Range("b27")
    LR = Sheets("VARIATIONS").Cells(Rows.Count, "B").End(xlUp).Row + 1
    Set r1 = Sheets("expansion lookups").Range("A2").CurrentRegion
    r1.Offset(1, 0).Resize(, 6).Copy Sheets("VARIATIONS").Cells(LR, 2)
    LRV = Sheets("VARIATIONS").Cells(Rows.Count, "B").End(xlUp).Row
    Sheets("VARIATIONS").Range("A" & LR & ":A" & LRV).Value = today

End Sub

Vuoi Approfondire?