You are here:---Rispondi a: [RISOLTO] Evitare salti di foglio
Rispondi a: [RISOLTO] Evitare salti di foglio2019-02-23T18:05:24+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Evitare salti di foglio Rispondi a: [RISOLTO] Evitare salti di foglio

sidsid
Moderatore
    Post totali: 718

    Ho dato una semplificata al codice.
    Ho accorpato tutto nell’evento del doppioclick, senza richiamare le macro del modulo1 e modulo2.
    Sicuramente migliorabile.

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim riga As Long
    Dim zona As Range
    
    Set wb1 = ThisWorkbook
    Set wb2 = Workbooks("file ANAGRAFICA-ANNO.xls")
    Set ws1 = wb1.Sheets("sms")
    Set ws2 = wb2.Sheets("DATI-CONTABILI")
    
    riga = Target.Row
    If riga < 5 Or riga > 2002 Then GoTo labf
    
    Application.ScreenUpdating = False
    Select Case Target.Column
        Case 3, 8, 13, 18, 23, 28, 33
        Set zona = Range(Target, Target.Offset(0, 4))
        With zona
            .Font.ColorIndex = 7 '2
            .Interior.ColorIndex = 7 '3
            .Copy
            ws1.Range("E23").PasteSpecial Paste:=xlValues  ' INCOLLA nome
        End With
    End Select
    
    With ws1
        .Range("A2").Copy
        .Range("E2").PasteSpecial Paste:=xlValues     ' INCOLLA data
        .Range("F1").Copy ' copia NOME FILTRATO
    End With
    
    With ws2
        .Range("A10").PasteSpecial Paste:=xlValues ' INCOLLA NOME FILTRATO
        With .Range("A10:CZ10")
            .AutoFilter ' disattiva il filtro (riga da aggiungere)
            .AutoFilter Field:=6, Criteria1:=ws2.Range("A10")
        End With
        .Range("F10:F10000").SpecialCells(xlCellTypeVisible).End(xlDown).Offset(0, 14).Copy ' COPIA segno zodiacale
        ws1.Range("B18").PasteSpecial Paste:=xlValues ' copia TELEFONO FILTRATO
    End With
    Application.CutCopyMode = False
    Cancel = True
    Me.Activate
    Application.ScreenUpdating = True
    
    labf: 'da mettere dopo l'end if
    
    Set wb1 = Nothing
    Set wb2 = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set zona = Nothing
    End Sub
    • Questa risposta è stata modificata 7 mesi, 4 settimane fa da sid sid.

    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