Copiare ultima riga scritta tramite macro.

Anonimo

Ciao,

ho provato a fare una ricerca ma, ahimè, non sono riuscito a trovare quello che mi occorre.

Tramite il pulsante "Aggiorna", dopo aver inserito manualmente nella prima riga i dati riportati nell'immagine, mi serve automatizzare i dati copiati e modificati dell'ultima riga scritta per incollarli alla successiva riga vuota.

Nell'esempio,

siccome nella cella "C2" c'è scritto "VINTA", gli eventi da 6 passerebbero (in A3) a 5 e gli attesi da 4 passerebbero (in B3) a 3.

Se nella cella "C2" ci fosse stato scritto "PERSA", gli eventi sarebbero passati ugualmente da 6 a 5, mentre gli attesi sarebbero rimasti a 4.

E così man mano a scendere.

Scrivo manualmente "VINTA" o "PERSA" e poi automatizzo i dati tramite macro.

Vladimiro

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

ho la seguente situazione:

Vorrei che la colonna A non facesse parte del codice nella macro Aggiorna in modo da scriverci qualsiasi cosa.

Option Explicit

Option Compare Text

Public Sub Aggiorna()

    Dim SH As Worksheet

    Dim srcRng As Range, destRng As Range, rCell As Range

    Dim i As Long, LRow As Long

   Dim blFlag As Boolean

    Set SH = ActiveSheet

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set srcRng = .Range("A1:D1").Offset(LRow - 1)

        With srcRng

            If .Cells(1, 5).Value = "VINTA" Or .Cells(1, 5).Value = "PERSA" Then

                blFlag = True

            End If

        End With

        If blFlag = False Then

            Exit Sub

        End If

        Set destRng = .Range("A" & LRow + 1)

    End With

    srcRng.Copy Destination:=destRng

    With destRng.Cells(1, 3)

        .Value = .Value - 1

    End With

    If UCase(srcRng.Cells(1, 5).Value) = "VINTA" Then

        With destRng.Cells(1, 4)

            .Value = .Value - 1

        End With

    End If

End Sub

Mi verrebbe da pensare di modificare questa riga di codice da così:

Set srcRng = .Range("A1:D1").Offset(LRow - 1)

a così:

Set srcRng = .Range("B1:D1").Offset(LRow - 1)

Però non implementa più nessuna cella.

Prova la seguente versione in cui le modifiche sono evidenziate in grassetto:

'=========>>

Option Explicit

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim LRow As Long

Dim blFlag As Boolean

On Error GoTo XIT

Application.EnableEvents = False

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("B:B"))

Set srcRng = .Range("B1:E1").Offset(LRow - 1)

With srcRng

If .Cells(1, 4).Value = "VINTA" _

Or .Cells(1, 4).Value = "PERSA" Then

blFlag = True

End If

End With

If blFlag = False Then

Exit Sub

End If

Set destRng = .Range("B" & LRow + 1)

End With

srcRng.Copy Destination:=destRng

With destRng.Cells(1, 3)

.Value = .Value - 1

End With

If UCase(srcRng.Cells(1, 4).Value) = "VINTA" Then

With destRng.Cells(1, 2)

.Value = .Value - 1

End With

End If

XIT:

Application.EnableEvents = True

End Sub

'<<=========

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

mi dispiace, ma non avevo notato che eliminando l'ultimo inserimento tramite il pulsante "Cancella ultimo rigo" mi esce sempre l'MsgBox.

Non è nulla di importante in quanto eliminando il messaggio dal codice risolverei il problema, però visto che stiamo in ballo, mi risolveresti anche questo?

Sostituiscilea procedure Aggiorna e Cancella_Righe_A_Ritroso con la seguente versione in cui le modifiche sono evidenziate in grassetto:

'=========>>

Option Explicit

Option Compare Text

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim i As Long, LRow As Long

Dim blFlag As Boolean

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("B:B"))

Set srcRng = .Range("A1:T1").Offset(LRow - 1)

With srcRng

If IsEmpty(.Cells(1)) Then

.Cells(2, 7).ClearContents

End If

If .Cells(1, 7).Value = "VINTA" _

Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

End If

End With

If blFlag = False Then

GoTo XIT

End If

Set destRng = .Range("A" & LRow + 1)

End With

With srcRng

If .Cells(1, 4) = 1 And .Cells(1, 7) = "VINTA" _

Or .Cells(1, 3) = 1 Then

MsgBox "Attenzione,gli attesi sono terminati." _

& vbCrLf & "E' pronta una nuova giocata.", vbCritical

On Error GoTo XIT

Application.EnableEvents = False

.Cells(2, 2) = SH.Range("B3").Value

.Cells(2, 3) = SH.Range("C3").Value

.Cells(2, 4) = SH.Range("D3").Value

.Cells(2, 5) = SH.Range("E3").Value

.Cells(2, 6) = SH.Range("F3").FormulaR1C1

.Cells(2, 8) = SH.Range("H3").FormulaR1C1

.Cells(2, 11) = SH.Range("A2").Value

.Cells(2, 12) = SH.Range("L3").FormulaR1C1

.Cells(1, 1).Interior.Color = RGB(255, 255, 102)

GoTo XIT

End If

.Copy Destination:=destRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

.Cells(2, 8).FormulaR1C1 = _

"=IF(R[-1]C[-1]=""VINTA"",R[-1]C[3]*(R[-1]C[6]" _

& "-R[-1]C[8])/(R[-1]C[8]*(RC[-3]-1))," _

& "IF(R[-1]C[-1]=""PERSA"", R[-1]C[3]* " _

& "(R[-1]C[10]-R[-1]C[12]) / (R[-1]C[12] *" _

& " (RC[-3]-1)),""""))"

.Cells(2, 11).FormulaR1C1 = _

"=IF(RC[-4]="""","""",IF(RC[-4]=""VINTA""," _

& "R[-1]C[0]-RC[-3]+(RC[-3]*RC[-6])," _

& "IF(RC[-4]=""PERSA"",R[-1]C[0]-RC[-3],"""")))"

End If

End With

With destRng

With .Cells(1, 3)

.Value = .Value - 1

End With

.Cells(1, 7).ClearContents

.Cells(1, 7).Activate

End With

If UCase(srcRng.Cells(1, 7).Value) = "VINTA" Then

With destRng.Cells(1, 4)

.Value = .Value - 1

End With

End If

XIT:

Application.EnableEvents = True

End Sub

'<<=========

'=========>>

Option Explicit

Public Sub Cancella_Righe_A_Ritroso()

Dim SH As Worksheet

Dim Rng As Range

Dim rRow As Range

Dim destRng As Range

Dim LRow As Long, i As Long

Const sIntervallo As String = "B250:T250"

Const iUltimaRigaDaCancellare As Long = 250

Const iPrimaRigaDaCancellare As Long = 3

On Error GoTo XIT

Application.EnableEvents = False

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Range("B3:B250"), iPrimaRigaDaCancellare)

Set Rng = .Range(sIntervallo).Offset(LRow - iUltimaRigaDaCancellare)

Set destRng = .Range("A" & LRow - 1)

End With

With Rng

If LRow = iPrimaRigaDaCancellare Then

.Cells(1, 6).ClearContents

Else

.ClearContents

With .Interior

.Pattern = xlNone

.TintAndShade = 0

.PatternTintAndShade = 0

End With

SH.Range("G3:G250").Interior.ColorIndex = 15 '<-colore grigio

SH.Range("A3:A250").Interior.Color = RGB(47, 117, 181) '<-colore blu

End If

End With

With destRng

.Cells(1, 7).Activate

End With

XIT:

Application.EnableEvents = True

End Sub

'<<=========

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

Bene, nel momento in cui si fa click sull' ESITO per inserire l'opzione Vinta o Persa aggiornando varie celle poste sullo stesso rigo, la logica vorrebbe che per continuare si facesse click sul pulsante Aggiorna.

Potrebbe succedere però che involontariamente ci si sposti al rigo successivo facendo click sull'ESITO senza fare prima click sul pulsante Aggiorna e questo non va bene.

Converrebbe fare la stessa cosa come è stato fatto per il pulsante Aggiorna nel momento in cui la cella dell'ESITO resta vuota: cioè non proseguire fintantoché non si inserisce Vinta o Persa.

Usando un po 'di pensiero laterale, penso che un approccio sarebbe quello di impedire l'inserimento di un esito su una riga vuota. Utilizzando il seguente codice, se un esito viene inserito inavvertitamente su una riga vuota, l'esito verrà eliminato e la cella nella riga precedente verrà selezionata. In questo modo, un esito non può essere inserito a meno che non sia stata eseguita la procedura di aggiornamento.

Quindi, prova qualcosa del genere:

Fai clic dx sulla linguetta del foglio di interesse

Seleziona l'opzione Visualizza Codice dal **** menu contestuale risultante

Incolla il seguente codice:

'=========>>

Option Explicit

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

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rng As Range

Set Rng = Intersect(Me.Columns("G"), Target)

If Not Rng Is Nothing Then

On Error GoTo XIT

Application.EnableEvents = False

With Rng

If IsEmpty(.Offset(0, -5)) Then

.ClearContents

.Offset(-1).Select

Call MsgBox( _

Prompt:="Devi aggiornare la riga prima di inserire un esito!!", _

Buttons:=vbCritical, _

Title:="REPORT")

End If

End With

End If

XIT:

Application.EnableEvents = True

End Sub

'<<=========

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

il problema è che una volta fatto click sul pulsante Aggiorna, la cella E3 viene compilata con la seguente formula:

=SE(A3="VINTA";B3+C3;SE(A3="PERSA";B3*C3))

mentre nel codice scritto:

With srcRng

If .Cells(0, 1) = "VINTA" Then

.Cells(2, 5) = SH.Range("E1").FormulaR1C1

End If

End With

mi dovrebbe rilasciare la seguente formula.

=SE(A1="VINTA";B1+C1;SE(A1="PERSA";B1*C1))

Prova:

With srcRng

If .Cells(0, 1) = "VINTA" Then

.Cells(2, 5) = SH.Range("E1").Formula

End If

End With

Posso chiederti altre due cose?

Non riesco a trovare il modo, una volta cancellato a ritroso le varie righe fino ad avere una sola riga con il seguente codice già postato sopra:

Prova qualcosa del genere:

'=========>>

Option Explicit

Public Sub Cancella_Righe_A_Ritroso()

Dim SH As Worksheet

Dim Rng As Range

Dim rRow As Range

Dim destRng As Range

Dim LRow As Long, i As Long

Const sIntervallo As String = "B250:T250" '<<=== Modifica

Const iUltimaRigaDaCancellare As Long = 250

Const iPrimaRigaDaCancellare As Long = 3

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Range("B3:B250"), iPrimaRigaDaCancellare)

Set Rng = .Range(sIntervallo).Offset(LRow - iUltimaRigaDaCancellare)

Set destRng = .Range("A" & LRow - 1)

End With

With Rng

If LRow = iPrimaRigaDaCancellare Then

.Cells(1, 6).ClearContents

Else

.ClearContents

With .Interior

.Pattern = xlNone

.TintAndShade = 0

.PatternTintAndShade = 0

End With

SH.Range("G3:G250").Interior.ColorIndex = 15

SH.Range("A3:A250").Interior.Color = RGB(47, 117, 181)

End If

End With

With destRng

.Cells(1, 7).Activate

End With

End Sub

'<<=========

Mi farebbe comodo, una volta inserito VINTA o PERSA nella colonna G, di non scendere di riga per aggiornare involontariamente sempre la colonna G con VINTA o PERSA se non si è fatto click sul pulsante aggiorna

Non capisco questo scenario in quanto l'immissione dell'esito, , utilizzando il menu a discesa, non risulta nello spostamento alla riga successiva.

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

al seguente link puoi trovare la mia demo.

Questa volta ho bisogno di un aiuto abbastanza impegnativo, ma vista la tua bravura, sono fiducioso. :-)

Nel momento in cui farai click sul pulsante aggiorna, uscirà un messaggio di fine partita in quanto gli attesi previsti nella cella D3 con ESITO VINTA sono stati raggiunti.

(Ci sarebbero potuti stare più esiti negativi (ESITO PERSA) la partita si sarebbe ugualmente chiusa con gli EVENTI = 1)

Dunque, i valori che troverai scritti sono solo dei numeri, mentre io ho bisogno nelle suddette celle:

RESA (F3), PUNTATA (H3), INCASSO (I3), UTILE (J3), CASSA ATTUALE (K e ultima riga), OBBIETTIVO (L3), M3:T3

di avere le stesse formule delle righe scritte in parentesi e da lì ripartire con un’altra partita.

Per avere l’ultima CASSA ATTUALE ho inserito una formula nella cella A2 (non ho saputo fare di meglio).

In più noterai la cella A8 formattata di sfondo giallo che sta ad indicare il rigo dove è finita la partita.

Vedi tu se il codice che ho scritto va bene.

Per ottenere le richieste formule anziché dei valori, prova a sostituire la procedura Aggiorna con qualcosa del genere:

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim i As Long, LRow As Long

Dim blFlag As Boolean

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("B:B"))

Set srcRng = .Range("A1:T1").Offset(LRow - 1)

With srcRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

End If

End With

If blFlag = False Then

Exit Sub

End If

Set destRng = .Range("A" & LRow + 1)

End With

With srcRng

If .Cells(1, 4) = 1 And .Cells(1, 7) = "VINTA" _

Or .Cells(1, 3) = 1 Then

MsgBox "Attenzione,gli attesi sono terminati." _

& vbCrLf & "E' pronta una nuova giocata.", vbCritical

.Cells(2, 2) = SH.Range("B3").Value

.Cells(2, 3) = SH.Range("C3").Value

.Cells(2, 4) = SH.Range("D3").Value

.Cells(2, 5) = SH.Range("E3").Value

.Cells(2, 6) = SH.Range("F3").FormulaR1C1

.Cells(2, 8) = SH.Range("H3").FormulaR1C1

.Cells(2, 11) = SH.Range("A2").Value

.Cells(2, 12) = SH.Range("L3").FormulaR1C1

.Cells(1, 1).Interior.Color = RGB(255, 255, 102)

Exit Sub

End If

.Copy Destination:=destRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

.Cells(2, 8).FormulaR1C1 = _

"=IF(R[-1]C[-1]=""VINTA"",R[-1]C[3]*(R[-1]C[6]" _

& "-R[-1]C[8])/(R[-1]C[8]*(RC[-3]-1))," _

& "IF(R[-1]C[-1]=""PERSA"", R[-1]C[3]* " _

& "(R[-1]C[10]-R[-1]C[12]) / (R[-1]C[12] *" _

& " (RC[-3]-1)),""""))"

.Cells(2, 11).FormulaR1C1 = _

"=IF(RC[-4]="""","""",IF(RC[-4]=""VINTA""," _

& "R[-1]C[0]-RC[-3]+(RC[-3]*RC[-6])," _

& "IF(RC[-4]=""PERSA"",R[-1]C[0]-RC[-3],"""")))"

End If

End With

With destRng

With .Cells(1, 3)

.Value = .Value - 1

End With

.Cells(1, 7).ClearContents

.Cells(1, 7).Activate

End With

If UCase(srcRng.Cells(1, 7).Value) = "VINTA" Then

With destRng.Cells(1, 4)

.Value = .Value - 1

End With

End If

End Sub

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

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

eccomi di nuovo per chiedere un'altra cosa.

With srcRng

.Copy Destination:=destRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

.Cells(2, 8).FormulaR1C1 = _

"=IF(R[-1]C[-1]=""VINTA"",RC[5]*(RC[8]" _

& "-RC[10])/(RC[10]*(RC[-3]-1))," _

& "IF(R[-1]C[-1]=""PERSA"",RC[6] * " _

& "(RC[12]-RC[14]) / (RC[14] *" _

& " (RC[-3]-1)),""""))"

.Cells(2, 11).FormulaR1C1 = _

"=IF(RC[-4]="""","""",IF(RC[-4]=""VINTA"",R[-1]C[0]-RC[-3]+(RC[-3]*RC[-6])," _

& "IF(RC[-4]=""PERSA"",R[-1]C[0]-RC[-3],"""")))"

End If

End With

con il codice evidenziato in grassetto, ottengo la seguente formula:

=SE(G4="";"";SE(G4="VINTA";K3-H4+(H4*E4);SE(G4="PERSA";K3-H4;"")))

io però ho bisogno di avere la cella K3 costante:

=SE(G4="";"";SE(G4="VINTA";$K$3-H4+(H4*E4);SE(G4="PERSA";$K$3-H4;"")))

come si può fare?

Prova:

'=========>>

Option Explicit

Option Compare Text

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim i As Long, LRow As Long

Dim blFlag As Boolean

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("B:B"))

Set srcRng = .Range("A1:L1").Offset(LRow - 1)

With srcRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

End If

End With

If blFlag = False Then

Exit Sub

End If

Set destRng = .Range("A" & LRow + 1)

End With

With srcRng

.Copy Destination:=destRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

.Cells(2, 8).FormulaR1C1 = _

"=IF(R[-1]C[-1]=""VINTA"",RC[5]*(RC[8]" _

& "-RC[10])/(RC[10]*(RC[-3]-1))," _

& "IF(R[-1]C[-1]=""PERSA"",RC[6] * " _

& "(RC[12]-RC[14]) / (RC[14] *" _

& " (RC[-3]-1)),""""))"

.Cells(2, 11).FormulaR1C1 = _

"=IF(RC[-4]="""","""",IF(RC[-4]=""VINTA""," _

& "R3C11-RC[-3]+(RC[-3]*RC[-6])," _

& "IF(RC[-4]=""PERSA"",R3C11-RC[-3],"""")))"

End If

End With

With destRng

With .Cells(1, 3)

.Value = .Value - 1

End With

.Cells(1, 7).ClearContents

End With

If UCase(srcRng.Cells(1, 7).Value) = "VINTA" Then

With destRng.Cells(1, 4)

.Value = .Value - 1

End With

End If

End Sub

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

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

Ciao Norman,

hai capito benissimo!!! :-)

La variabile srcRng l'hai sfruttata due volte.

Un'altra cosa.

Premetto che ho risolto diversamente, però, volendo avere sempre l'ESITO della cella precedente,

da così:

=SE(G4="VINTA";M4*(P4-R4)/(R4*(E4-1));SE(G4="PERSA";N4 * (T4-V4) / (V4 * (E4-1));""))

a così:

=SE(G3="VINTA";M4*(P4-R4)/(R4*(E4-1));SE(G3="PERSA";N4 * (T4-V4) / (V4 * (E4-1));""))

come dovrebbe essere modificata la seguente formula?

With srcRng

.Copy Destination:=destRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

.Cells(2, 8).FormulaR1C1 = _

"=IF(RC[-1]=""VINTA"",RC[5]*(RC[8]" _

& "-RC[10])/(RC[10]*(RC[-3]-1))," _

& "IF(RC[-1]=""PERSA"",RC[6] * " _

& "(RC[12]-RC[14]) / (RC[14] *" _

& " (RC[-3]-1)),""""))"

End If

End With

Vladimiro

Sempre a condizione che io abbia capito, prova qualcosa del genere:

'=========>>

Option Explicit

Option Compare Text

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim i As Long, LRow As Long

Dim blFlag As Boolean

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("B:B"))

Set srcRng = .Range("A1:L1").Offset(LRow - 1)

With srcRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

End If

End With

If blFlag = False Then

Exit Sub

End If

Set destRng = .Range("A" & LRow + 1)

End With

With srcRng

.Copy Destination:=destRng

If .Cells(1, 7).Value = "VINTA" Or .Cells(1, 7).Value = "PERSA" Then

blFlag = True

.Cells(2, 8).FormulaR1C1 = _

"=IF(R[-1]C[-1]=""VINTA"",RC[5]*(RC[8]" _

& "-RC[10])/(RC[10]*(RC[-3]-1))," _

& "IF(R[-1]C[-1]=""PERSA"",RC[6] * " _

& "(RC[12]-RC[14]) / (RC[14] *" _

& " (RC[-3]-1)),""""))"

End If

End With

With destRng

With .Cells(1, 3)

.Value = .Value - 1

End With

.Cells(1, 7).ClearContents

End With

If UCase(srcRng.Cells(1, 7).Value) = "VINTA" Then

With destRng.Cells(1, 4)

.Value = .Value - 1

End With

End If

End Sub

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

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If Rng Is Nothing Then

Set Rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

.Unprotect Password:=sPassword

End If

End With

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

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

End Function

'<<=========

===

Regards,

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

sicuramente mi sono spiegato male in quanto non è quello che cercavo.

In definitiva cerco di fare degli esempi semplici in modo da capire meglio come imparare il tuo codice per sfruttarlo meglio.

Per il momento lasciamo perdere la colonna E con le formule in quanto ho capito come funziona.

Come ti dicevo, inserendo una ulteriore colonna dopo la colonna dell'ESITO dove si deve scrivere manualmente VINTA o PERSA, non riesco ad avere, dopo aver incollato i risultati nella riga successiva, la suddetta colonna dell'ESITO vuota.

Tagliamo la testa al toro, ti posto le immagini con il risultato da ottenere:

Spero di aver chiarito meglio la mia esigenza.

Tutto chiaro e con una soluzione semplice:

'=========>>

Option Explicit

Option Compare Text

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim i As Long, LRow As Long

Dim blFlag As Boolean

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("A:A"))

Set srcRng = .Range("A1:E1").Offset(LRow - 1)

With srcRng

If .Cells(1, 4).Value = "VINTA" Or .Cells(1, 4).Value = "PERSA" Then

blFlag = True

.Cells(2, 6).FormulaR1C1 = _

"=IF(RC[-2]=""VINTA"",RC[9]*(RC[12]" _

& "-RC[14])/(RC[14]*(RC[1]-1))," _

& "IF(RC[-2]=""PERSA"",RC[10] * " _

& "(RC[16]-RC[18]) / (RC[18] *" _

& " (RC[1]-1)),""""))"

End If

End With

If blFlag = False Then

Exit Sub

End If

Set destRng = .Range("A" & LRow + 1)

End With

srcRng.Copy Destination:=destRng

With destRng

With .Cells(1, 2)

.Value = .Value - 1

End With

.Cells(1, 4).ClearContents

End With

If UCase(srcRng.Cells(1, 4).Value) = "VINTA" Then

With destRng.Cells(1, 3)

.Value = .Value - 1

End With

End If

End Sub

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

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If Rng Is Nothing Then

Set Rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

.Unprotect Password:=sPassword

End If

End With

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

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

End Function

'<<=========

Potrest scaricare il mio file di prova Vladimiro20191029.xlsm

===

Regards

Norman

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Vladimiro,

comincio a capire qualcosina in più.

Intanto la modifica d'apportare è in questo rigo di codice:

With destRng.Cells(1, 3)

e va bene.

Domanda:

volendo lasciare invariata la colonna A ricopiando sempre la cella A2, come dovrei modificare il codice?

Per quanto riguarda la demo, ho visto che per il momento lasci inattivi i dati scritti in rosso, andando ad implementare fino alla colonna D.

Per il momento mi basta in quanto ho visto che c'è molto da studiare :-)

Aspetto la risposta precedente.

Prova la seguente versione:

'=========>>

Option Explicit

Option Compare Text

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

Public Sub Aggiorna()

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range, rCell As Range

Dim i As Long, LRow As Long

Dim blFlag As Boolean

Set SH = ActiveSheet

With SH

LRow = LastRow(SH, .Columns("A:A"))

Set srcRng = .Range("A1:C1").Offset(LRow - 1)

With srcRng

If .Cells(1, 4).Value = "VINTA" Or .Cells(1, 4).Value = "PERSA" Then

blFlag = True

.Cells(2, 5).FormulaR1C1 = _

"=IF(RC[-1]=""VINTA"",RC[9]*(RC[12]" _

& "-RC[14])/(RC[14]*(RC[1]-1))," _

& "IF(RC[-1]=""PERSA"",RC[10] * " _

& "(RC[16]-RC[18]) / (RC[18] *" _

& " (RC[1]-1)),""""))"

End If

End With

If blFlag = False Then

Exit Sub

End If

Set destRng = .Range("A" & LRow + 1)

End With

srcRng.Copy Destination:=destRng

With destRng.Cells(1, 2)

.Value = .Value - 1

End With

If UCase(srcRng.Cells(1, 4).Value) = "VINTA" Then

With destRng.Cells(1, 3)

.Value = .Value - 1

End With

End If

End Sub

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

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If Rng Is Nothing Then

Set Rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

.Unprotect Password:=sPassword

End If

End With

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

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

End Function

'<<=========

Ho aggiornato il mio file di prova Vladimiro20191028(1).xlsm

===

Regards,

Norman

0 commenti

46 risposte aggiuntive

Anonimo

2019-10-25T08:29:11+00:00

Ciao Vladimiro,

per ottenere assistenza specializzata per questo tipo di richieste relativa alla creazione di una MACRO, ti suggerisco di fare affidamento al nostro forum specializzato in questi quesiti, raggiungibile tramite questo link.

In alto a destra, clicca su "formula una domanda" e poni la tua domanda al forum.

Mi auguro di esserti stato di aiuto.

Ti auguro una buona giornata.

Dario
La risposta è stata utile?

0 commenti Nessun commento