Pagina precedente | 1 | Pagina successiva
Vota | Stampa | Notifica email    
Autore

Doppio click su di una cella di una specifica colonna: seleziona il range adiacente, coloralo, incollalo in un altro foglio

Ultimo Aggiornamento: 26/01/2021 17:37
Post: 163
Registrato il: 03/09/2018
Città: GROTTAGLIE
Età: 25
Utente Junior
Microsoft Office Professional Plus 2019 64 bit
OFFLINE
26/01/2021 12:02

Doppio click su di una cella di una specifica colonna: seleziona il range adiacente, coloralo, incollalo in un altro foglio
Buongiorno a tutto il forum, ho bisogno del vostro aiuto perché non riesco a completare un codice.
Sono riuscita a scrivere (aiutandomi col web) una private sub (nel foglio DATA) e delle sub ad essa collegate per realizzare quanto segue:
Doppio Click su di una cella della colonna a7:a10000 e, se non è vuota, colora la cella di grigio per poi copiarne il contenuto ed incollarlo in uno dei tre fogli (TEST1, TESt2, TEST3) a seconda del contenuto. Se nella cella vi è il contenuto "SOLUZIONE1" allora copierà "SOLUZIONE1" e lo incollerà nel foglio TEST1 (se "SOLUZIONE2" nel foglio TEST2, se "SOLUZIONE3" nel foglio TEST3).

Il problema è che non voglio copiare (e colorare) quella cella su cui eseguo il doppio click ma il range ad essa adiacente.
Per esempio, nel file in allegato, dove ho inserito i codici, ho fatto manualmente quello che desidero:
doppio click sulla cella A7, colora il range B7:H7, lo copio e lo incollo nel foglio TEST1.
Grazie
[Modificato da Melissa2018 26/01/2021 12:05]
Post: 4.559
Registrato il: 21/06/2013
Città: NAPOLI
Età: 70
Utente Master
Excel 365
OFFLINE
26/01/2021 12:53

Ciao Melissa felice che ci si ritrovi.

Questa è la macro che fa quanto hai chiesto.

Cancella tutto il codice che hai nel file

vb
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Long
Dim ur As Long
Dim sh As Worksheet
Select Case Right(Target.Value, 1)
     Case Is = 1
     Set sh = Foglio2
     Case Is = 2
     Set sh = Foglio3
     Case Is = 3
     Set sh = Foglio4
End Select
ur = sh.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 7
    sh.Cells(ur + 1, i).Value = Target.Offset(0, i).Value
Next i
Cancel = True
End Sub
[Modificato da alfrimpa 26/01/2021 12:53]

Alfredo
Post: 884
Registrato il: 24/06/2015
Città: CATANIA
Età: 80
Utente Senior
Excel2019
OFFLINE
26/01/2021 12:57

Ciao
OLtre all'ottima soluzione di @alfrimpa (ciao Alfredo) ti propongo a mia
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'Dim rng As Range, cl As Range
'Set rng = Range("A7:A10000")
'For Each cl In rng.Cells
'If Target.Address = cl.Address And Target = "SOLUZIONE1" Then MACROTEST
'If Target.Address = cl.Address And Target = "SOLUZIONE2" Then MACROTEST2
'If Target.Address = cl.Address And Target = "SOLUZIONE3" Then MACROTEST3
'Next

If Not Intersect(Target, Range("A7:A10000")) Is Nothing Then
  If Target <> "" Then
    sh = Right(Target, 1)
    Range(Cells(Target.Row, 2), Cells(Target.Row, 8)).Copy
    rg = Sheets("TEST" & sh).Cells(Rows.Count, 1).End(xlUp).Row + 1
    Sheets("TEST" & sh).Cells(rg, 1).PasteSpecial Paste:=xlPasteAll
  End If
End If
End Sub



Ciao,
Mario
Post: 3.047
Registrato il: 06/04/2013
Utente Master
2010
OFFLINE
26/01/2021 16:47

Ciao
manca la colorazione in entrambe le soluzioni proposte
Integro quella di Mario (scusi tanto) perchè è più corta😁

saluti

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A7:A10000")) Is Nothing Then
  If Target <> "" Then
    sh = Right(Target, 1)
    Range(Cells(Target.Row, 2), Cells(Target.Row, 8)).Interior.ColorIndex = 15
    Range(Cells(Target.Row, 2), Cells(Target.Row, 8)).Copy
    rg = Sheets("TEST" & sh).Cells(Rows.Count, 1).End(xlUp).Row + 1
    Sheets("TEST" & sh).Cells(rg, 1).PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False
  End If
End If
Cancel = True
End Sub





[Modificato da dodo47 26/01/2021 16:47]
Domenico
Win 10 - Excel 2016
Post: 163
Registrato il: 03/09/2018
Città: GROTTAGLIE
Età: 25
Utente Junior
Microsoft Office Professional Plus 2019 64 bit
OFFLINE
26/01/2021 17:37

Buonasera a tutti! Grazie ai vostri preziosi contributi ho imparato meglio a gestire anche questi comandi. Il ventaglio di applicazioni che mi si è aperto mi tornerà tremendamente utile.
Grazie Alfredo, grazie Mario e grazie Domenico🎁🙏
Vota: 15MediaObject5,0035 3
Amministra Discussione: | Chiudi | Sposta | Cancella | Modifica | Notifica email Pagina precedente | 1 | Pagina successiva
Nuova Discussione
 | 
Rispondi
Cerca nel forum
Tag discussione
Discussioni Simili   [vedi tutte]
Feed | Forum | Bacheca | Album | Utenti | Cerca | Login | Registrati | Amministra
Tutti gli orari sono GMT+01:00. Adesso sono le 01:53. Versione: Stampabile | Mobile | Regolamento | Privacy
FreeForumZone [v.6.1] - Copyright © 2000-2024 FFZ srl - www.freeforumzone.com