Click per copiare una riga tabella

[Ricky0185]

Prova questo file, ovviamente quando lo apri abilita le macro.
DoppioCliccando SOLO sulla colonna B12:B100 (hai detto che arriverai ad un massimo di 100 rghe) del Foglio1, automaticamente copia l'intera riga sul Foglio2 in B6 e la cancella sul Foglio1. Anche se metti i filtri fa lo stesso lavoro.
Se DoppioClicchi in qualunque altra parte del foglio che non sia entro B12:B100, la macro non si attiva. Se invece vuoi che si attivi quando DoppioClicchi entro la tabella di Foglio1 i.e. B12:P100 devi sostituire nella macro la riga
If Intersect(Target, [B12:B100]) Is Nothing Then Exit Sub
con
If Intersect(Target, [B12:P100]) Is Nothing Then Exit Sub
Prova e dicci.
Tutta farina del sacco di Anthony.

[Anthony47]

L'errore e' in questa Private Sub Worksheet_Change, che lascia gli eventi disabilitati; modifica come segue:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Area As String, inArea As Range, myC As Range

Application.EnableEvents = False
If Target.Address = "$B$17" Then 'Se modifico la cella B17 Cancella il contenuto di C17
    Range("C17").ClearContents
End If
If Target.Address = "$G$17" Then   'Se modifico la cella G17 Cancella il contenuto di H17, I17, J17
    Range("H17, I17, J17").ClearContents
'    Application.EnableEvents = True       '** Rimossa da qui         
End If
Application.EnableEvents = True            '** INSERITA QUI
End Sub


Guarda le righe marcate **

[marte1503]

per Anthony

Oh oh... A forza di smanettare con copia e incolla ho fatto un po' di confusione
Grazie Anthony!!


Per Ricky

Ciao Ricky, ho provato a scaricare il file che mi hai suggerito ma non ricordavo la password.. Sono abituato ad accedere in automatico con il telefono.
Ho provato a spuntare il comando "password dimenticata" ma su cellulare mi è arrivata una email che non mi è piaciuta, google mi ha avvisato che c'era un tentativo di accedere al mio account da Ciriè Provincia di Torino chiedendomi se fossi io o no. Mi è venuto il dubbio che qualcuno abbia clonato il mio pc e ho annullato tutto.

Mi sa che ho qualche virus nel pc...

[Ricky0185]

Allora prova a scaricarlo da qui

[Ricky0185]

Comunque questa è la macro che devi inserire sul Foglio dove c'è la tabella che hai detto che comincia da B12 a P12 e dove poi andrai ad inserire altre righe B13, B14, etc.
Devi solo sostituire nella macro i Foglio2 con il nome del Foglio dove verranno copiate le righe cliccate.

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [B12:B100]) Is Nothing Then Exit Sub
Cancel = True
rispo = MsgBox("Spostare la riga selezionata su Foglio2 e cancellarla da questa posizione?" & vbCrLf _
       & "OK per confermare, ANNULLA per annullare  ", vbOKCancel)
    If rispo <> vbOK Then
        Target.Select
        Exit Sub
    End If
ActiveCell.EntireRow.Copy Destination:=Worksheets("Foglio2").Range("A6") '.End(xlDown).Offset(1, 0)
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub

Vai con la freccetta del mouse sulla linguetta del Foglio dove c'è la tabella. Cliccaci su con tasto destro e poi su Visualizza Codice.
Nella finestra che ti appare incolla sulla metà di destra la macro. Lascia se ci sono altre macro, le potrai cancellare dopo se non ti servono.
Chiudi la finestra e poi torna sul foglio della tabella. E DoppiaClick su una qualsiasi cella della colonna B a partire dalla B12.
Rileggi poi il mio precedente messaggio per eventuali modifiche.

[marte1503]

Per Ricky

Ok Ricky,
sono riuscito a scaricare il tuo file.
La macro esegue il trasferimento della riga come nel mio caso, ma la grossa differenza che vedo è che non elimina la riga dalla tabella dopo averla incollata in foglio2, per me è essenziale eliminare l'intera riga, non solo la cella che attiva il trasferimento della riga come succede nel tuo esempio..


Per Anthony

Anthony, all'inizio avevo detto che non volevo farti perdere troppo tempo, invece...

Con un po' di vergogna ti chiedo un ultimo aiuto (per questa macro )

ho provato ad aggiungere dei comandi ai piedi della macro (parlo di quella che trasferisce la riga) per tentare di cancellare un range nel foglio di destinazione ma va in errore..

- Dopo aver incollato la riga,(sempre nel Foglio destinazione) dovrebbe cancellare i dati presenti in questo range:
- B17:E17, G17:J17, L17, P17

grazie...

[Ricky0185]

Se si sbaglia bisogna rimediare.
Hai ragione, non cancella la riga origine. Per farlo sostituisci nella macro
Selection.Delete Shift:=xlUp
con
Selection.EntireRow.Delete
Poi, per cancellare quei valori che hai chiesto, prima di End Sub aggiungi

Codice: Seleziona tutto

Range("B17: E17 , G17: J17 , L17, P17").Select
    Range("P17").Activate
    Selection.ClearContents ‘se vuoi solo cancellare i valori nelle celle
    Selection.EntireRow.Delete ‘se vuoi eliminare le intere righe

Buon lavoro

[marte1503]

Ciao Ricky,
grazie per l'aiuto

Ho inserito le righe che mi hai scritto nella parte finale della mia macro, ora finisce così:

Codice: Seleziona tutto

Application.ScreenUpdating = True                                           '
End If
Range("B17: E17 , G17: J17 , L17, P17").Select
    Range("P17").Activate
    Selection.ClearContents
End Sub


Però non funziona, evidenzia in giallo la riga con i vari range da pulire
e mi dà questo errore:

Errore di run-time '1004':
Errore nel metodo Select per la classe Range

[Ricky0185]

Stai mescolando le macro, quella che ti ha inviato Anthony con il suggerimento che ti ho inviato io.
Inserisci

Codice: Seleziona tutto

Sheets("Foglio1").Select

dove Foglio1 è quello della tabella,
prima di

Codice: Seleziona tutto

Range("B17:E17,H17:I17,K17,M17,O17").Select
    Range("O17").Activate
    Selection.ClearContents
End Sub

A me, con la macro che ti ho inviato, funziona egregiamente, trasferisce su Foglio2 la riga cliccata su Foglio1 cancellandola poi ed infina cancella quelle celle su Foglio1.

[marte1503]

Guarda Ricky,
apprezzo il tuo aiuto e ti ringrazio, è sempre bello prendere spunto da chi ne sa di più, ma dopo aver fatto perdere non so quanto tempo a Anthony questa fase di programma la porto a termine con la macro pensata e costruita da lui, aspetto quindi la sua correzione appena avrà tempo di modificare di nuovo il codice
Tengo presente anche la tua versione per una eventuale utilizzo futuro.
Ti ringrazio ancora e ti auguro un buon 2023.
Ciao

[Anthony47]

Per cancellare quegli intervalli, modificare l'ultima parte della Sub Worksheet_BeforeDoubleClick, da Selection.Delete Shift:=xlUp alla fine, come segue:

Codice: Seleziona tutto

    Selection.Delete Shift:=xlUp
   
    Range("A1").Select 'aggiunto per evitare che rimanesse selezionata la riga tabella sottostante a quella esportata
    Sheets("Foglio1").Select  'aggiunto per terminare in foglio destinazione
    Sheets("Foglio1").Range("B17: E17 , G17: J17 , L17, P17").ClearContents            '++++ AZZERA B17:E17, G17:J17, L17, P17
    Application.EnableEvents = True
''Application.ScreenUpdating = True
End If
End Sub


Ciao

[marte1503]

Ti ringrazio Anthony, tutto perfettamente funzionante!

Mi pare che tra le mie prove, anch'io avessi scritto la stessa informazione copiandola da un'altra macro, ora non ricordo bene perchè ho fatto più tentativi, ma credo di aver posizionato le informazioni dopo il comando Application.enableEvents=true", tu invece l'hai inserito prima. (Altro mattoncino di esperienza che aggiungo).

Ti faccio un'ultima domanda:

Ho visto che l'ultima informazione : "application.screen.updating = true" l'hai lasciata sotto forma di commento

- Il comando "Application.enableEvents=true" fa la stessa funzione di "addormentare lo schermo per tutta la durata della procedura"?
Con quale criterio si preferisce l'uno all'altro?

Grazie ancora di tutto

Ti faccio i migliori Auguri di Buon Anno!

Ciao

[Anthony47]

Application.ScreenUpdating = False /True serve per "congelare /scongelare" lo schermo nel corso di una macro.
La nostra macro non va avanti e indietro tra i fogli, per cui c'e' poco da congelare, e infatti la macro non ha una Application.ScreenUpdating=false; a questo punto la Application.ScreenUpdating=true che ho lasciato commentata (quindi disabilitata) e' superflua

Application.EnableEvents = False /True serve invece per disabilitare altri "eventi"; l'avevamo inserita per non farci disturbare dalla Worksheet_Change che lasciava gli eventi disabilitati

Insomma sono due gestioni diverse

[marte1503]

Ciao Anthony,
questa volta credevo di riuscire a cavarmela invece rimbalzo contro un muro di gomma..

Ho provato a modificare le istruzioni della macro che mi avevi preparato in questo topic, per riadattarle alle nuove esigenze ma non riesco a farla funzionare...

Per cercare di ricordarti la precedente richiesta senza farti andare a ritroso, posto la macro Funzionante che ho attualmente nel modulo del mio Foglio

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomeTab As String

'Questa Macro seleziona una riga in Tabella213 (contenente i dati Macchina(es. tipo pistone, tipo verniciatura ecc.)
'e la incolla in Foglio1, lì i dati verranno corretti in base alle specifiche dell' Ordine Cliente

NomeTab = "Tabella213"
Application.ScreenUpdating = False
'
If Not Application.Intersect(Target, Me.ListObjects(NomeTab).DataBodyRange) Is Nothing Then

    Cells(Target.Row, "B").Resize(1, 18).Select
    Cancel = True
    rispo = MsgBox("Spostare la riga selezionata su Foglio Ordine Cliente e cancellarla da questa posizione?" & vbCrLf _
       & "OK per confermare, ANNULLA per annullare  ", vbOKCancel)
    If rispo <> vbOK Then
        Target.Select
        Exit Sub
    End If
    Application.EnableEvents = False
    Selection.Copy Sheets("Foglio1").Range("B9")
    Sheets("Foglio1").Range("B9").Resize(1, 18).Value = Selection.Value
    Application.CutCopyMode = False
    csel = Selection.Address
    If Target.ListObject.AutoFilter.FilterMode Then Target.ListObject.AutoFilter.ShowAllData
    Range(csel).Select
    Selection.Delete Shift:=xlUp
   
    Range("A1").Select 'aggiunto per evitare che rimanesse selezionata la riga tabella sottostante a quella esportata
    Sheets("Foglio1").Select  'aggiunto per terminare in foglio destinazione
    Sheets("Foglio1").Range("C17: L17 , N17, R17, H22: H121").ClearContents            '<<<< AZZERA Eventuali VECCHI valori
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Sheets("Foglio1").Range("F2").Select
    ActiveWindow.SmallScroll Down:=-80
        ActiveWindow.SmallScroll ToRight:=-50
    Application.EnableEvents = True
MsgBox ("Inserire Versione SW")
End If
End Sub

Con questa macro
- viene selezionata una riga a caso in Tabella 213
- viene eliminata da suddetta Tabella e viene incollata in Foglio1 partendo da CellaB9

La nuova macro che ho provato a creare modificando la tua e aggiungendo qualche riga ottenuta con il registratore continua ad andare in errore, ho provato a maneggiarla ma non riesco proprio a debuggarla..

Questa variante dovrebbe:
- selezionare una riga qualsiasi da Tabella2133, Eliminarla, e incollarle il tutto in Tabella21334 aggiungendo una riga a questa Tabella (nella precedente versione la riga veniva incollata in un intervallo fisso di Foglio1)

Posto la macro per farti vedere i nuovi comandi e i nuovi Range.

Come al solito ti ringrazio per l'aiuto

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomeTab As String

'Questa Macro seleziona una riga in Tabella2133 (contenente i dati Macchina in attesa di ritiro)
'e la incolla in Foglio8 (archivio storico Macchine Vendute)

NomeTab = "Tabella2133"
Application.ScreenUpdating = False
'
If Not Application.Intersect(Target, Me.ListObjects(NomeTab).DataBodyRange) Is Nothing Then

    Cells(Target.Row, "B").Resize(1, 20).Select
    Cancel = True
    rispo = MsgBox("Spostare la riga selezionata nell'Archivio Storico delle Vendite e cancellarla da questa posizione?" & vbCrLf _
       & "OK per confermare, ANNULLA per annullare  ", vbOKCancel)
    If rispo <> vbOK Then
        Target.Select
        Exit Sub
    End If

   

    Sheets("Foglio8").Select
    ActiveSheet.Unprotect
    Range("Tabella21334").Select  '<<<<<<<<<<<<<<<<<<<<<<<VA SEMPRE IN ERRORE IN QUESTO PUNTO
    Selection.ListObject.ListRows.Add (1)
   
   
   
   
    Sheets("Foglio7").Unprotect
    Selection.Copy Sheets("Foglio8").Range("B12")
    Sheets("Foglio8").Range("B12").Resize(1, 20).Value = Selection.Value
    Application.CutCopyMode = False
    csel = Selection.Address
    If Target.ListObject.AutoFilter.FilterMode Then Target.ListObject.AutoFilter.ShowAllData
    Range(csel).Select
    Selection.Delete Shift:=xlUp
   
    Range("A1").Select 'aggiunto per evitare che rimanesse selezionata la riga tabella sottostante a quella esportata
    Sheets("Foglio8").Select  'aggiunto per terminare in foglio destinazione
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Sheets("Foglio8").Range("A2").Select
    ActiveWindow.SmallScroll Down:=-80
        ActiveWindow.SmallScroll ToRight:=-50


End If
End Sub

[Anthony47]

Secondo me ce la puoi fare; devi pero' tenere a mente che il codice scritto nel "modulo vba del fogliox" fa riferimento, per definizione, al contenuto di fogliox, A MENO CHE non indichi l'indirizzo assoluto.
Quindi la riga va in errore perche' sul fogliox un Range("Tabella21334") non esiste (si trova invece in Foglio8); quindi nel tuo codice (che non ho guardato in profondita') tutte le volte che vuoi far riferimento a qualcosa fuori da Fogliox lo devi dire esplicitamente; quindi, per cominciare:

Codice: Seleziona tutto

Sheets("Foglio8").Unprotect
Sheets("Foglio8").Range("Tabella21334").Select


E per debuggare una macro: viewtopic.php?f=26&t=103893&p=647677#p647677

Prova...

[marte1503]

Anthony, ho provato a correggere con le tue indicazioni ma

mi sa che mi sopravvaluti..

posto la macro con la correzione che ho provato a inserire

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomeTab As String

'Questa Macro seleziona una riga in Tabella2133 (contenente i dati Macchina in attesa di ritiro)
'e la incolla in Foglio8 (archivio storico Macchine Vendute)

NomeTab = "Tabella2133"
Application.ScreenUpdating = False
'
If Not Application.Intersect(Target, Me.ListObjects(NomeTab).DataBodyRange) Is Nothing Then

    Cells(Target.Row, "B").Resize(1, 20).Select
    Cancel = True
    rispo = MsgBox("Spostare la riga selezionata nell'Archivio Storico delle Vendite e cancellarla da questa posizione?" & vbCrLf _
       & "OK per confermare, ANNULLA per annullare  ", vbOKCancel)
    If rispo <> vbOK Then
        Target.Select
        Exit Sub
    End If

   
   
    Sheets("Foglio8").Select  '<<<<<<<<<<<<<<  AGGIUNTO PER EVITARE L'ERRORE 3 RIGHE PIU' SOTTO
    Sheets("Foglio8").Unprotect
    Sheets("Foglio8").Range("Tabella21334").Select  '<<<<<<<<<<<<<<<<<QUI
    Selection.ListObject.ListRows.Add (1)
   
   
    '<<<<<<<<<<<<<<<  ORA MI INSERISCE CORRETTAMENTE LA RIGA NELLA TABELLA 21334
   
   
    Sheets("Foglio7").Unprotect
   
    Selection.Copy Sheets("Foglio8").Range("B12")
    Sheets("Foglio8").Range("B12").Resize(1, 20).Value = Selection.Value
    Application.CutCopyMode = False
    csel = Selection.Address
    If Target.ListObject.AutoFilter.FilterMode Then Target.ListObject.AutoFilter.ShowAllData
    Range(csel).Select  '<<<<<<<<<<<<<<<<<<<<  NUOVO ERRORE
    Selection.Delete Shift:=xlUp
   
    Range("A1").Select 'aggiunto per evitare che rimanesse selezionata la riga tabella sottostante a quella esportata
    Sheets("Foglio8").Select  'aggiunto per terminare in foglio destinazione
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Sheets("Foglio8").Range("A2").Select
    ActiveWindow.SmallScroll Down:=-80
        ActiveWindow.SmallScroll ToRight:=-50


End If
End Sub

con le istruzioni che HO inserito, ora aggiunge la riga in tabella 21334 come dovrebbe, ma l'errore si è spostato più sotto e non conosco il significato dell'informazione Range(csel).Select

[Anthony47]

Prova con questa versione:

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomeTab As String
Dim cTRow As Long, dTRow As Long

'Questa Macro seleziona una riga in Tabella2133 (contenente i dati Macchina in attesa di ritiro)
'e la incolla in Foglio8 (archivio storico Macchine Vendute)

NomeTab = "Tabella2133"
''Application.ScreenUpdating = False
If Not Application.Intersect(Target, Me.ListObjects(NomeTab).DataBodyRange) Is Nothing Then
    Cancel = True
    rispo = MsgBox("Spostare la riga selezionata nell'Archivio Storico delle Vendite e cancellarla da questa posizione?" & vbCrLf _
       & "OK per confermare, ANNULLA per annullare  ", vbOKCancel)
    If rispo <> vbOK Then
        Target.Select
        Exit Sub
    End If
    Application.EnableEvents = False
   cTRow = Target.Row - Target.ListObject.ListRows(1).Range.Row + 1     'Riga corrente
    With Sheets("Foglio8")
        .Unprotect
        .ListObjects("Tabella21334").ListRows.Add
        With .Range("Tabella21334")
            dTRow = .Cells(.Rows.Count, 1).End(xlUp).Row - .Cells(1, 1).Row + 2     'Dove scrivere
        End With
        Target.ListObject.ListRows(cTRow).Range.Copy .ListObjects("Tabella21334").ListRows(dTRow).Range
        .Protect                'Protegge Foglio8
        End With
    Me.Unprotect                                'Sprotegge foglio con Tabella 2133..
    Target.ListObject.ListRows(cTRow).Delete    '... elimina riga..
    Me.Protect                                  '... e riprotegge
End If
Application.EnableEvents = True
End Sub


Ho inserito qualche ghiotto commento per spiegare

[marte1503]

Ciao Anthony,
grazie 1000 per la macro!

Noto che è un po' diversa da quella precedente, non fa più riferimento al numero delle colonne, purtroppo, malgrado le tue indicazioni mi riesce ancora più complicato interpretala...

Mi scuso se passa un sacco di tempo prima che ti risponda, ma nella vita faccio tutt'altro e posso smanettare con excel soltanto di sera dopo il lavoro fino a quando mi tocca gettare la spugna per sonno e stanchezza..

Questa macro, sposta la riga da Tabella2133 a Tabella21334 come ti avevo chiesto, però ho notato che viene aggiunta in coda a quelle già presenti, ti chiederei se gentilmente potresti incollarla nella posizione più in alto, praticamente sotto ai nomi Colonne, in questo modo avrei la più vecchia in basso.

Le l'informazione da correggere come mi hai scritto nei commenti è in questa riga

Codice: Seleziona tutto

dTRow = .Cells(.Rows.Count, 1).End(xlUp).Row - .Cells(1, 1).Row + 2     'Dove scrivere
        End With


ma non saprei come modificare i dati..( ho provato sostituendo il + 2 con - 2 ma....)

Mi sono accorto anche di aver fatto una grossa pecca, stupidamente non ho previsto un sistema per avere un riferimento di Data di archiviazione, mi faresti un grosso favore se potessi aggiungere questa informazione sempre tramite macro in modo che venga archiviata insieme alla riga trasferita. A questo proposito ho pensato di ovviare aggiungendo altre 2 Colonne sulla destra in Tabella 21334: (Colonna V e W)

Colonna V per l'anno
Colonna W per mese & giorno insieme

Grazie ancora..

[Anthony47]

Per copiare la riga in testa alla tabella allora la macro si semplifica (non bisogna infatti cercare la posizione su cui scrivere).
Per scrivere anno / mm&gg su colonne che aggiungerai:
-assegna a queste due colonne rispettivamente l'intestazione Anno e MM-GG
-poi inseriamo le istruzioni per compilare queste due celle subito dopo aver copiato la riga nella seconda tabella.

Quindi:

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomeTab As String
Dim cTRow As Long, dTRow As Long
'
'Questa Macro seleziona una riga in Tabella2133 (contenente i dati Macchina in attesa di ritiro)
'e la incolla in Foglio8 (archivio storico Macchine Vendute)

NomeTab = "Tabella2133"
''Application.ScreenUpdating = False           'inutile
If Not Application.Intersect(Target, Me.ListObjects(NomeTab).DataBodyRange) Is Nothing Then
    Cancel = True
    rispo = MsgBox("Spostare la riga selezionata nell'Archivio Storico delle Vendite e cancellarla da questa posizione?" & vbCrLf _
       & "OK per confermare, ANNULLA per annullare  ", vbOKCancel)
    If rispo <> vbOK Then
        Target.Select
        Exit Sub
    End If
    Application.EnableEvents = False
    cTRow = Target.Row - Target.ListObject.ListRows(1).Range.Row + 1        'Riga corrente da copiare
    With Sheets("Foglio8")
        .Unprotect
        .ListObjects("Tabella21334").ListRows.Add (1)                       'aggiunge riga in testa
        Target.ListObject.ListRows(cTRow).Range.Copy .ListObjects("Tabella21334").ListRows(1).Range   'Copia e incolla su riga 1
        .Range("Tabella21334[Anno]").Cells(1, 1) = Year(Date)               '...aggiunge Anno
        .Range("Tabella21334[MM-GG]").Cells(1, 1) = Format(Date, "mmm-dd")  '...aggiunge mmm-gg
        .Protect                                                            'Protegge Foglio8
    End With
    Me.Unprotect                                                            'Sprotegge foglio con Tabella 2133..
    Target.ListObject.ListRows(cTRow).Delete                                '... elimina riga..
    Me.Protect                                                              '... e riprotegge
End If
Application.EnableEvents = True
End Sub


Ho anche arricchito i commenti

[marte1503]

Grazie Anthony!
Funziona correttamente sia l'archiviazione che le informazioni sulla data nelle 2 nuove colonne.
Domani sera controllo tutto con più attenzione.
Per ora ti ringrazio.
Ciao