![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Excel | Per la casa | Windows
Una famiglia di software per fogli di calcolo Microsoft con strumenti per l'analisi, la creazione di grafici e la comunicazione dei dati.
Ciao By EF,
sono quasi alla fine del progetto quindi prometto che smetterò di monopolizzare e stressare la community ( comunque spero che i miei spunti siano di aiuto anche ad altri utenti).
Vorrei aggregare due miei threads precedentemente risolti:
e
In pratica nel file allegato post intervento di Norman ( che ringrazio ancora):
https://www.dropbox.com/s/s9dy9lqi7saphkg/GePreVForumNDJ.xlsm?dl=0
Quando nel foglio di lavoro "sommario" digito il numero del preventivo (es 17-001) oltre a compilare i campi come da script "variazione-testo-in-una-cella", possa creare sempre in colonna "A" ,un collegamento ipertestuale che mi permetta, se necessario di "spostarmi" aprendo direttamente il foglio di lavoro interessato.
Nel modulo di codice del foglio sommario sostituisci il codice precedente con la seguente versione:
'=========>>
Option Explicit
'--------->>
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WB As Workbook
Dim SH As Worksheet
Dim RngA As Range, RngB As Range, rCell As Range
Dim fg As String
Dim bAvviso As Boolean
Const sKeyWord As String = "positivo"
Const sCellaTotale As String = "X32"
Set WB = ThisWorkbook
If Not Intersect(Target, Me.Columns("A:B")) Is Nothing Then
On Error GoTo XIT
Application.EnableEvents = False
With WB
Set RngA = Intersect(Target, Columns("A:A"))
Set RngB = Intersect(Target, Columns("B:B"))
End With
fg = Me.Cells(Target.Row, 1).Value
If SheetExists(fg, WB) Then
Set SH = WB.Sheets(fg)
Else
bAvviso = True
GoTo XIT
End If
End If
If Not RngA Is Nothing Then
With RngA.Cells(1)
SH.Cells(.Row, 2) = Me.Cells(.Row, 2)
.Offset(0, 2).Value = SH.Range("B1").Value
.Offset(0, 1).Value = SH.Range("V1").Value
.Offset(0, 9).Value = SH.Range("Y36").Value
Call AddHyperlink(SH, .Item(1))
End With
End If
If Not RngB Is Nothing Then
With RngB.Cells(1)
If UCase(.Value) = UCase(sKeyWord) Then
.Offset(0, 7).Value = SH.Range(sCellaTotale).Value
End If
End With
End If
XIT:
If bAvviso Then
Call MsgBox( _
Prompt:="Il foglio " & fg & " non è stato trovato!", _
Buttons:=vbCritical, _
Title:="PROBLEMA?")
End If
Application.EnableEvents = True
End Sub
'<<=========
Nel modulo standard, sostituisci il codice delle funzione SheetExists con:
'=========>>
Option Explicit
'--------->>
Public Sub AddHyperlink(aSH As Worksheet, rCell As Range)
Dim sName As String
sName = aSH.Name
aSH.Hyperlinks.Add _
Anchor:=rCell, _
Address:="", _
SubAddress:="'" & sName & "'!A1", _
TextToDisplay:=sName
End Sub
'--------->>
Public Function SheetExists(sSheetName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then
Set WB = ThisWorkbook
End If
SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))
End Function
'<<=========
Potresti scaricare il mio file di prova EF20170902.xlsm
===
Regards,
Norman