You are here:---Rispondi a: [RISOLTO] UF Ricerca Materiale – Bottone Elimina
Rispondi a: [RISOLTO] UF Ricerca Materiale – Bottone Elimina2017-11-24T15:52:50+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] UF Ricerca Materiale – Bottone Elimina Rispondi a: [RISOLTO] UF Ricerca Materiale – Bottone Elimina

BySalvBySalv
Amministratore del forum
    Post totali: 460

    Ciao REAPAT eccoti la Macro Modificata, è segnato dove sono intervenuto.

    Private Sub CommandButton20_Click() 'elimina materiale
    Dim Risp As Integer, Lrow As Long
    Dim r As Long, Ir As Long, i As Long
    Dim ComputerName
    '--------------------------------------------------- righe aggiunte
    Dim rr, x, k, sh1 As Worksheet, sh2 As Worksheet
    
    Set sh1 = Worksheets("Scheda_Prodotti")
    Set sh2 = Worksheets("MaterialiEliminati")
    sh1.Activate
    '--------------------------------------------- Fine righe aggiunte
    
    Dim ora
    ora = Now
    Risp = MsgBox("Vuoi eliminare questo materiale ?", vbInformation + vbYesNo, "Controllo dati")
    Ir = 2
        If Risp = vbYes Then
            Lrow = Sheets("MaterialiEliminati").Range("A" & Rows.Count).End(xlUp).Row + 1
            Application.Calculation = xlCalculationManual
            For r = 0 To ListBox1.ListCount - 1
                 If ListBox1.Selected(r) = True Then
                    k = ListBox1.List(r, 6) '---------------------- riga aggiunta
                    Exit For
                 End If
            Next r
            Application.Calculation = xlCalculationAutomatic
        Else
            MsgBox "Nessun dato è stato rimosso!", vbExclamation, "Operazione Annulata!"
            Exit Sub
        End If
    '----------------------------------- righe aggiunte
    If sh2.Cells(2, 1) = "" Then rr = 2 Else rr = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    For x = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
        If sh1.Cells(x, 7) = k Then
            Range(sh1.Cells(x, 1), sh1.Cells(x, 8)).Copy sh2.Cells(rr, 1)
            Range(sh1.Cells(x, 1), sh1.Cells(x, 8)).Delete
            Exit For
        End If
    Next x
    '----------------------------------- fine righe aggiunte
    MsgBox "Operazione effettuata con successo!", vbInformation, "Aggiornamento dati"
    
     Risp = Empty
     Lrow = Empty
     r = Empty
     Ir = Empty
     i = Empty
     ComputerName = Empty
     ora = Empty
     UserForm_Activate
    End Sub 

    Ti allego anche il File

    http://www.filedropper.com/ricercamaterialeiniziale2

    Ogni prodotto eliminato viene riportato nel foglio “MaterialiEliminati”

    Ciao By Sal :bye:

    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