|
  07/01/2016 08:07 | |
Salve! Allora apro questa discussione perchè mi trovo a utilizzare il seguente codice in un foglio di lavoro, per far sì che il testo possa andare a capo in celle unite fra loro orizzontalmente, in modo che le stesse vengano automaticamente ridimensionate in altezza.
Ora il problema del codice è quel "Range("D23").Select" alla fine, che è una forzatura che ho inserito io perchè venga selezionata quella casella per evitare che il cursore vada a casaccio ogni volta che si termina di scrivere in una cella o fare qualunque altra operazione.
Siccome ciò è causato dal codice stesso, mi chiedevo se c'è qualcosa che posso cambiare nel codice o magari che posso aggiungere al posto di "Range("D23").Select" perchè venga selezionata invece la cella sottostante a quella attiva, ovvero quella in cui si sta scrivendo, quando si preme invio o freccia in basso.
Grazie.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
ActiveSheet.Unprotect
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
Range( _
"A21:I49,I51,I52,I53,I54,H1:I1,H3:I3,H6:I6,F12:I12,F13:I13,G14:I14,G15:I15,G16:I16,G17:I17,G18:I18,C12:D12,B13:D13,B14:D14,A15:D15,A16:D16,A17:D17,A18:D18" _
).Select
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
Range("D23").Select
End Sub
|
|
| | Post: 4.642 | Registrato il: 14/11/2004
| Utente Master | Office 2019 | | OFFLINE |
|
| 07/01/2016 09:23 | |
Ciao a parte che eliminerei quando più possibile le celle unite, in quanto specialmente con il VBA creano problemi e non solo il VBA.
ma utilizzerei un approccio diverso sfruttare l'evento "Selection_Change" del foglio per "Dilatare" la cella, vedi l'esempio, prima e dopo aver selezionato la cella
[IMG]http://i67.tinypic.com/21eb0g4.jpg[/IMG]
[IMG]http://i67.tinypic.com/5fpu7s.jpg[/IMG]
in questo modo non credo avrai problemi
ma dovrai darmi più spiegazioni, magari con un esempio(file) della tua realtà, in modo che si possano adattare i riferimenti.
fai sapere, Ciao By Sal ![[SM=x423051]](http://www.erismag.it/Servizio/ForumExcel/Smiles/Faccina_0031.gif)
[Modificato da by sal 07/01/2016 09:27] se ti piace la soluzione sostienici con una DONAZIONE a piacere. Grazie clicca qui |
|
| 07/01/2016 10:32 | |
è la prima volta che mi trovo a dover "condividere" un file o porzione di esso come esempio e non so come si fa ![[SM=g27833]](https://im0.freeforumzone.it/up/0/33/6206759.gif) |
| | Post: 4.643 | Registrato il: 14/11/2004
| Utente Master | Office 2019 | | OFFLINE |
|
| 07/01/2016 11:35 | |
Ciao, se il file non contiene macro ed è inferiore alla versione 2007 allora quando scrivi il post sotto gli smile ce un pulsante Carica File/foto, lo premi scegli il file sul tuo pc e dai ok
se invece contiene Macro e la versione excel è superiore alla 2003 devi comprimerlo con zip o rar e po fai la procedura sopra, non riconosce il formato Xlsx o xlsm etc..
tutto qui elimina dati sensibili se ci sono.
Ciao By Sal
se ti piace la soluzione sostienici con una DONAZIONE a piacere. Grazie clicca qui |
|
| 07/01/2016 15:43 | |
Ho capito, chiedo scusa per il ritardo, ebbene ecco il file su cui sto lavorando. Spero che così sia più facile trovare una soluzione. |
| | Post: 4.645 | Registrato il: 14/11/2004
| Utente Master | Office 2019 | | OFFLINE |
|
| 07/01/2016 16:28 | |
Ciao Devi fare solo le modifiche alla macro sopradescritta, che allego, non ho manomesso niente altro.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim rr as long'----------------< aggiunta
rr = Target.Row + 1 '------------------< aggiunta
ActiveSheet.Unprotect
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
Range( _
"A21:I49,I51,I52,I53,I54,H1:I1,H3:I3,H6:I6,F12:I12,F13:I13,G14:I14,G15:I15,G16:I16,G17:I17,G18:I18,C12:D12,B13:D13,B14:D14,A15:D15,A16:D16,A17:D17,A18:D18" _
).Select
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
Range("D" & rr).Select '----------------< modificata
End Sub il tuo problema dichiarando di selezionare la "D23" il cursore dopo aver inserito qualsiasi cosa si andava a posizionare sempre nella stessa cella doveva essere variabile in base all'inserimento della descrizione.
vedi ci stanno le righe aggiunte e quella modificata in basso.
Ciao by sal
[Modificato da by sal 07/01/2016 16:31] se ti piace la soluzione sostienici con una DONAZIONE a piacere. Grazie clicca qui |
|
| 07/01/2016 16:37 | |
Grazie mille! Così è già molto meglio |
|
|
|
|