Moderatori: Anthony47, Flash30005
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
If Target.Column > 1 And Target.Column < 17 Then
Cells(Target.Row, "B").Resize(1, 15).Select
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
Selection.Copy
Sheets("Foglio2").Range("B9").PasteSpecial xlPasteValues
Sheets("Foglio2").Range("B9").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If
End Sub
Clickando in con il pulsante DX si attiva correttamente la finestra che mi avvisa come ti avevo chiesto, ma confermando :
- La riga viene incollata a destinazione senza riportare alcun tipo di valore, resta completamente vuota in tutto l'intervallo
- Cancella i bordi neri che circondano le celle interessate
- Cancella la formattazione condizionale presente nella Cella G8
- Rimuove la centratura dei dati all'interno delle celle
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
If Target.Column > 1 And Target.Column < 17 Then
Cells(Target.Row, "B").Resize(1, 15).Select
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
Selection.Copy Sheets("Foglio2").Range("B9")
Sheets("Foglio2").Range("B9").Resize(1, 15).Value = Selection.Value
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If
End Sub
Sub Inserisce_la_x_con_click_mouse()
'
' Inserisce_la_x_con_doppioclick_mouse
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Inserisce_la_x_con_doppioclick_mouse
CheckareaC = "C17:C23,E17:E23,G17:G23,I17:I23"
If Not Application.Intersect(Target, Range(CheckareaC)) Is Nothing Then
If Target = "" Then
Target = "x"
Else
Target.ClearContents
End If
End If
Cancel = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Area As String, inArea As Range, myC As Range
'Se modifico la cella B4, B7, D7 Cancella le altre celle di immissione dati
Application.EnableEvents = False
If Target.Address = "$B$7" Then
Range("D7, F7, H7, J7, B10, D10, B13,D13,F13,H10:J13").ClearContents
ElseIf Target.Address = "$D$7" Then
Range("F7, H7, J7, B10, B13, D10, B13, D13, F13, H10:J13").ClearContents
ElseIf Target.Address = "$B$4" Then
Range("D4,F4,B7,D7, F7, H7, J7, B10, D10, B13,D13,F13,H10:J13").ClearContents
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<MODIFICA
ElseIf Target.Address = "$B$13" Then
Range("D13,F13").ClearContents
End If
Application.EnableEvents = True
'
Area = "B7" '<<< l'area da convertire in maiuscolo
Set inArea = Application.Intersect(Target, Range(Area))
If Not inArea Is Nothing Then
Application.EnableEvents = False
For Each myC In inArea
If myC.Value <> "" Then
myC.Value = UCase(myC.Value)
End If
Next myC
Application.EnableEvents = True
End If
Dim mySeq As String, mySplit, inList
'Stabilisce in quale ordine si attiveranno le celle dopo aver premuto il pulsante INVIO
mySeq = "B4,D4,F4,B7,D7,F7,H7,J7,B10,D10,B13,D13,F13,H10,H10"
mySplit = Split(Replace(mySeq, " ", "", , , vbTextCompare), ",", , vbTextCompare)
inList = Application.Match(Target.Cells(1, 1).Address(0, 0), mySplit, False)
If Not IsError(inList) Then
Range(mySplit(inList + 0)).Select
End If
'
End Sub
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)-Se togli l'apostrofo te le incolla in sequenza
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlUp
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
If Target.Column > 1 And Target.Column < 17 Then
Cells(Target.Row, "B").Resize(1, 15).Select
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
Application.EnableEvents = False '**
Selection.Copy Sheets("Foglio2").Range("B9")
Sheets("Foglio2").Range("B9").Resize(1, 15).Value = Selection.Value
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Application.EnableEvents = True '**
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Se non funziona allora o mandi il pc a Lourdes oppure ti rassegni a preparare un file dimostrativo su cui fare le stesse prove
Ciao
Selection.Delete Shift:=xlUp
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim NomeTab As String
'
NomeTab = "Tabella1" '<<< il nome assegnato alla tua tabella
'
If Not Application.Intersect(Target, Me.ListObjects(NomeTab).DataBodyRange) Is Nothing Then
'If Target.Column > 1 And Target.Column < 17 Then
Cells(Target.Row, "B").Resize(1, 15).Select
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
Application.EnableEvents = False '**
Selection.Copy Sheets("Foglio2").Range("B9")
Sheets("Foglio2").Range("B9").Resize(1, 15).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
' Selection.ClearContents
Application.EnableEvents = True '**
End If
End Sub
Selection.ClearContents
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, 15).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, 15).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
Application.EnableEvents = True
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
Application.ScreenUpdating = True
End If
End Sub
Sub Inserisce_la_x_con_click_mouse_bis()
'
' Inserisce_la_x_con_doppioclick_mouse
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Inserisce_la_x_con_doppioclick_mouse
CheckareaF = "F22:F61"
If Not Application.Intersect(Target, Range(CheckareaF)) Is Nothing Then
If Target = "" Then
Target = "X"
Else
Target.ClearContents
End If
End If
Cancel = True
End Sub
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
End If
End Sub
Torna a Applicazioni Office Windows
Ordinare colonne sulla stessa riga se stesso contenuto Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 10 |
File batch per copiare file selezionato da menu contestuale Autore: valle1975 |
Forum: Programmazione Risposte: 3 |
Aumenta altezza riga in base valore cella Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 47 |
Visitano il forum: Nessuno e 38 ospiti