Ho apportato le modifiche che hanno comportato un po' "stravolgimento" rispetto alla cartella di lavoro precedente un po' per capirmi meglio io :-) e un po' per fare in modo che se il codice dovesse essere letto da terzi non italiani forse potrebbe risultare
più comprensibile. Per quanto non so se sono riuscito a raggiungere questo obiettivo :-)
Questo il link: File esempio #6
Ho aggiunto i due fogli realtivi alla Technical Crew e ai relativi Certtificate e ho rinominato i fogli (e quindi anche i nomi indicati nelle dichiarazionio costanti iniziali).
- Maritime Crew
- Maritime Certificate
- Technical Crew
- Technical Certificate
Poiché la ListBox destinata a contenere i nominativi ora non è più relativa ai soli maritime l'ho rinominata, più genericamente, LB_Crew.
Per gestire il diverso caricamento di dati ho quindi creato due distinte procedure che vengono richiamate in base alla TabStrip selezionata (LoadMaritimeCrew e LoadTechnicalCrew).
Ho anche modificato il nome di alcune variabili nella speranza che rendano più compresibile lo scopo a cui sono destinate (un paio ora hanno un nome assolutamente "verboso" :-)).
Ho modificato le descrizioni che vengono inserite in caso di certificati obbligatori scaduti inserendo in luogo del numero di giorni negativo il testo "Expirate!". Mentre se mancano meno di 90gg e fino all'ultimo giorno inserisce il numero di giorni mancanti.
Per i certificati obbligatori senza data ho ripetuto due volte il testo "To be done!". Mi è sembrato che così colpisse più all'occhio.
Ovviamente, se la soluzione non ti piacesse, ti basterebbe andare ad modificare le righe di comando dove trovi il testo "Expired!" e "To be done!" per ripristinare alla situazione precedente.
Ho creato delle costanti dove ho inserito i parametri per le larghezze delle colonne delle ListBox e le ho assegnate alle rispettive proprietà ColumnWidths.
In questo modo ti sarà più agevole modificare i parametri in base alle misure effettive delle tue listbox.
Ho anche impostato che nelle LB_Mandatory e LB_Racommended compaia il ControlTipText della ListBox nel caso gli ultimi 4 caratteri nelle intestazioni di Certificate siano composte da "(1*)" (fino al 5 ma ovviamente da te replicabile in base ad esigenza).
Tieni presente che se la nota è presente nelle intestazioni dei fogli Certificate, Maritime o Technical, dovranno essere presenti nelle intestazioni dei fogli Crew (altrimenti nella fase di confronto tra le intestazioni presenti nel foglio Crew con quelle
presenti nel foglio Certificate non troverebbe la corrispondenza).
Provando un po' non è che mi piaccia molto il comportamento del ControlTipText. Va bene quando selezioni la prima volta una riga con la "nota". Se però poi ne selezioni una diversa, sempre rimanendo all'interno della ListBox" per vedere il nuoto testo occorre
spostare il puntatore del mouse fuori dalla listbox e poi rientrare.
Ma volendo al posto dell'impstazione del ControlTipText puoi far comparire dei MsgBox con il testo legato alla relativa nota.
Mi pare di aver riepilogato le modifiche, spero in maniera completa :-)
Ora a te l'onere di testare il tutto :-)
Riporto anche tutto il codice come modificato e integrato (tutto contenuto sempre nella UserForm2):
'---
Option Explicit
'<--- costanti relative ai fogli di lavoro --->
Const sNameWs1 As String = "Maritime Crew" 'Personale marittimo
Const sWs1Rng1 As String = "A1"
Const sNameWs2 As String = "Maritime Certificate" 'Corsi personale marittimo
Const sWs2Rng1 As String = "A1"
Const sNameWs3 As String = "Technical Crew" 'Personale tecnico
Const sWs3Rng1 As String = "A1"
Const sNameWs4 As String = "Technical Certificate" 'Corsi Personale tecnico
Const sWs4Rng1 As String = "A1"
'<--- constanti larghezza colonne delle ListBox --->
Const sColWidthLB_MaritimeCrew As String = "2,5 cm;5 cm;1,5 cm"
Const sColWidthLB_ThechnicalCrew As String = "3,5 cm;5,5 cm"
Const sColWidthLB_CertificateOnBoard As String = "13,75 cm;1,5 cm"
Const sColWidthLB_CertificateExpired As String = "10,75 cm;3 cm;2 cm"
'<--- dichiarazioni variabili relative ai fogli di lavoro --->
Dim Wb As Workbook
Dim Ws1 As Worksheet
Dim Ws1Rng1 As Range
Dim CR1 As Range
Dim NumRowCR1 As Integer
Dim NumColumnCR1 As Integer
Dim Ws2 As Worksheet
Dim Ws2Rng1 As Range
Dim CR2 As Range
Dim NumRowCR2 As Integer
Dim NumColumnCR2 As Integer
Dim Ws3 As Worksheet
Dim Ws3Rng1 As Range
Dim CR3 As Range
Dim NumRowCR3 As Integer
Dim NumColumnCR3 As Integer
Dim Ws4 As Worksheet
Dim Ws4Rng1 As Range
Dim CR4 As Range
Dim NumRowCR4 As Integer
Dim NumColumnCR4 As Integer
'<--- variabile per data odierna --->
Dim Today As Date
Private Sub UserForm_Initialize()
'<--- dichiarazioni variabili e impostazioni array intestazioni ListBox --->
Dim sLB_Header_Crew As Variant
Dim sLB_Header_CertificateOnBoard As Variant
Dim sLB_Header_CertificateExpired As Variant
sLB_Header_Crew = Array("Rank", "Surname & Name", "Badge Nr")
sLB_Header_CertificateOnBoard = Array("Certificate Type", "Expiring Date")
sLB_Header_CertificateExpired = Array("Certificate Type", "Expiring Date", "Day Left")
'<--- Impostazioni Workbook, Worksheets e Range --->
Set Wb = ThisWorkbook
With Wb
'<--- WorkSheet Maritime Crew --->
Set Ws1 = .Worksheets(sNameWs1)
Set Ws1Rng1 = Ws1.Range(sWs1Rng1)
Set CR1 = Ws1Rng1.CurrentRegion
NumRowCR1 = CR1.Rows.Count
NumColumnCR1 = CR1.Columns.Count
'<--- WorkSheet Maritime Certificate --->
Set Ws2 = .Worksheets(sNameWs2)
Set Ws2Rng1 = Ws2.Range(sWs2Rng1)
Set CR2 = Ws2Rng1.CurrentRegion
NumRowCR2 = CR2.Rows.Count
NumColumnCR2 = CR2.Columns.Count
'<--- WorkSheet Technical Crew --->
Set Ws3 = .Worksheets(sNameWs3)
Set Ws3Rng1 = Ws3.Range(sWs3Rng1)
Set CR3 = Ws3Rng1.CurrentRegion
NumRowCR3 = CR3.Rows.Count
NumColumnCR3 = CR3.Columns.Count
'<--- WorkSheet Technical Certificate --->
Set Ws4 = .Worksheets(sNameWs4)
Set Ws4Rng1 = Ws4.Range(sWs4Rng1)
Set CR4 = Ws4Rng1.CurrentRegion
NumRowCR4 = CR4.Rows.Count
NumColumnCR4 = CR4.Columns.Count
End With
'<--- memorizzo la data odierna --->
Today = Date
'<--- impostazioni iniziali ListBox --->
With Me
.TabStrip1.Value = 0
With .LB_Crew
.List() = CR1.Offset(1, 0).Resize(NumRowCR1 - 1, 3).Value
.ColumnCount = 3
.ColumnWidths = sColWidthLB_MaritimeCrew
End With
With .LB_Header_Crew
.Column() = sLB_Header_Crew
.ColumnCount = 3
.ColumnWidths = sColWidthLB_MaritimeCrew
End With
With .LB_CertificateOnBoard
.ColumnCount = 2
.ColumnWidths = sColWidthLB_CertificateOnBoard
End With
With .LB_Header_CertificateOnBoard
.Column() = sLB_Header_CertificateOnBoard
.ColumnCount = 2
.ColumnWidths = sColWidthLB_CertificateOnBoard
End With
With .LB_CertificateExpired
.ColumnCount = 3
.ColumnWidths = sColWidthLB_CertificateExpired
End With
With .LB_Header_CertificateExpired
.Column() = sLB_Header_CertificateExpired
.ColumnCount = 3
.ColumnWidths = sColWidthLB_CertificateExpired
End With
End With
End Sub
Private Sub LB_Crew_Click()
With Me
If .TabStrip1.Value = 0 Then
Call LoadMaritimeCrew
ElseIf .TabStrip1.Value = 1 Then
Call LoadTechnicalCrew
End If
.LB_Mandatory.ControlTipText = Empty
.LB_Racommended.ControlTipText = Empty
End With
End Sub
Private Sub LB_Mandatory_Click()
With Me
With .LB_Mandatory
Select Case Right(.List(.ListIndex), 4)
Case "(1*)"
.ControlTipText = "Nota " & "(1*)"
Case "(2*)"
.ControlTipText = "Nota " & "(2*)"
Case "(3*)"
.ControlTipText = "Nota " & "(3*)"
Case "(4*)"
.ControlTipText = "Nota " & "(4*)"
Case "(5*)"
.ControlTipText = "Nota " & "(5*)"
Case Else
.ControlTipText = Empty
End Select
End With
End With
End Sub
Private Sub LB_Racommended_Click()
With Me
With .LB_Racommended
Select Case Right(.List(.ListIndex), 4)
Case "(1*)"
.ControlTipText = "Nota " & "(1*)"
Case "(2*)"
.ControlTipText = "Nota " & "(2*)"
Case "(3*)"
.ControlTipText = "Nota " & "(3*)"
Case "(4*)"
.ControlTipText = "Nota " & "(4*)"
Case "(5*)"
.ControlTipText = "Nota " & "(5*)"
Case Else
.ControlTipText = Empty
End Select
End With
End With
End Sub
Private Sub TabStrip1_Change()
Dim sLB_Header_Crew As Variant
With Me
If .TabStrip1.Value = 0 Then
Call ClearListBox
With .LB_Crew
.List() = CR1.Offset(1, 0).Resize(NumRowCR1 - 1, 3).Value
.ColumnCount = 3
.ColumnWidths = sColWidthLB_MaritimeCrew
End With
With .LB_Header_Crew
sLB_Header_Crew = Array("Rank", "Surname & Name", "Badge Nr")
.ColumnCount = 3
.Column() = sLB_Header_Crew
.ColumnWidths = sColWidthLB_MaritimeCrew
End With
ElseIf .TabStrip1.Value = 1 Then
Call ClearListBox
With .LB_Crew
.List() = CR3.Offset(1, 0).Resize(NumRowCR3 - 1, 2).Value
.ColumnCount = 2
.ColumnWidths = sColWidthLB_ThechnicalCrew
End With
With .LB_Header_Crew
sLB_Header_Crew = Array("Rank", "Surname & Name")
.ColumnCount = 2
.Column() = sLB_Header_Crew
.ColumnWidths = sColWidthLB_ThechnicalCrew
End With
End If
End With
End Sub
Private Sub LoadMaritimeCrew()
Dim sJobTitle As String
Dim sCrewName As String
Dim FindCertificateFromWsCertificate As Range
Dim FindCertificateFromWsCrew As Range
Dim i As Integer, t As Integer
Call ClearListBox
With Me
With .LB_Crew
sJobTitle = .List(.ListIndex, 0)
sCrewName = .List(.ListIndex, 1)
End With
Set FindCertificateFromWsCertificate = CR2.Resize(NumRowCR2, 1).Find(What:=sJobTitle, _
After:=Ws2Rng1, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
Set FindCertificateFromWsCrew = CR1.Resize(NumRowCR1, 1).Offset(0, 1).Find(What:=sCrewName, _
After:=Ws1Rng1.Offset(0, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
For i = 1 To NumColumnCR2 - 1
If Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "M" Then
.LB_Mandatory.AddItem Ws2Rng1.Offset(0, i).Value
End If
If Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "R" Then
.LB_Racommended.AddItem Ws2Rng1.Offset(0, i).Value
End If
For t = 1 To NumColumnCR1 - 3
If Ws1Rng1.Offset(0, t + 2).Value = Ws2Rng1.Offset(0, i).Value Then
If FindCertificateFromWsCrew.Offset(0, t + 1).Value <> "" Then
If IsDate(FindCertificateFromWsCrew.Offset(0, t + 1).Value) And _
Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "M" Then
If FindCertificateFromWsCrew.Offset(0, t + 1).Value > Today + 90 Then
With .LB_CertificateOnBoard
.AddItem
.List(.ListCount - 1, 0) = Ws1Rng1.Offset(0, t + 2).Value
.List(.ListCount - 1, 1) = FindCertificateFromWsCrew.Offset(0, t + 1).Value
End With
Else
With .LB_CertificateExpired
.AddItem
.List(.ListCount - 1, 0) = Ws1Rng1.Offset(0, t + 2).Value
.List(.ListCount - 1, 1) = FindCertificateFromWsCrew.Offset(0, t + 1).Value
If FindCertificateFromWsCrew.Offset(0, t + 1).Value - Today > 0 Then
.List(.ListCount - 1, 2) = FindCertificateFromWsCrew.Offset(0, t + 1).Value - Today
Else
.List(.ListCount - 1, 2) = "Expired!"
End If
End With
End If
Else
With .LB_CertificateOnBoard
.AddItem
.List(.ListCount - 1, 0) = Ws1Rng1.Offset(0, t + 2).Value
.List(.ListCount - 1, 1) = FindCertificateFromWsCrew.Offset(0, t + 1).Value
End With
End If
Else
If Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "M" Then
With .LB_CertificateExpired
.AddItem
.List(.ListCount - 1, 0) = Ws1Rng1.Offset(0, t + 2).Value
.List(.ListCount - 1, 1) = "To be done!"
.List(.ListCount - 1, 2) = "To be done!"
End With
End If
End If
End If
Next t
Next i
End With
End Sub
Private Sub LoadTechnicalCrew()
Dim sJobTitle As String
Dim sCrewName As String
Dim FindCertificateFromWsCertificate As Range
Dim FindCertificateFromWsCrew As Range
Dim i As Integer, t As Integer
Call ClearListBox
With Me
With .LB_Crew
sJobTitle = .List(.ListIndex, 0)
sCrewName = .List(.ListIndex, 1)
End With
Set FindCertificateFromWsCertificate = CR4.Resize(NumRowCR4, 1).Find(What:=sJobTitle, _
After:=Ws4Rng1, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
Set FindCertificateFromWsCrew = CR3.Resize(NumRowCR3, 1).Offset(0, 1).Find(What:=sCrewName, _
After:=Ws3Rng1.Offset(0, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
For i = 1 To NumColumnCR4 - 1
If Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "M" Then
.LB_Mandatory.AddItem Ws4Rng1.Offset(0, i).Value
End If
If Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "R" Then
.LB_Racommended.AddItem Ws4Rng1.Offset(0, i).Value
End If
For t = 1 To NumColumnCR3 - 2
If Ws3Rng1.Offset(0, t + 1).Value = Ws4Rng1.Offset(0, i).Value Then
If FindCertificateFromWsCrew.Offset(0, t).Value <> "" Then
If IsDate(FindCertificateFromWsCrew.Offset(0, t).Value) And _
Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "M" Then
If FindCertificateFromWsCrew.Offset(0, t).Value > Today + 90 Then
With .LB_CertificateOnBoard
.AddItem
.List(.ListCount - 1, 0) = Ws3Rng1.Offset(0, t + 1).Value
.List(.ListCount - 1, 1) = FindCertificateFromWsCrew.Offset(0, t).Value
End With
Else
With .LB_CertificateExpired
.AddItem
.List(.ListCount - 1, 0) = Ws3Rng1.Offset(0, t + 1).Value
.List(.ListCount - 1, 1) = FindCertificateFromWsCrew.Offset(0, t).Value
If FindCertificateFromWsCrew.Offset(0, t).Value - Today > 0 Then
.List(.ListCount - 1, 2) = FindCertificateFromWsCrew.Offset(0, t).Value - Today
Else
.List(.ListCount - 1, 2) = "Expired!"
End If
End With
End If
Else
With .LB_CertificateOnBoard
.AddItem
.List(.ListCount - 1, 0) = Ws3Rng1.Offset(0, t + 1).Value
.List(.ListCount - 1, 1) = FindCertificateFromWsCrew.Offset(0, t).Value
End With
End If
Else
If Left(UCase(FindCertificateFromWsCertificate.Offset(0, i).Value), 1) = "M" Then
With .LB_CertificateExpired
.AddItem
.List(.ListCount - 1, 0) = Ws3Rng1.Offset(0, t + 1).Value
.List(.ListCount - 1, 1) = "To be done!"
.List(.ListCount - 1, 2) = "To be done!"
End With
End If
End If
End If
Next t
Next i
End With
End Sub
Private Sub ClearListBox()
With Me
.LB_Mandatory.Clear
.LB_Racommended.Clear
.LB_CertificateOnBoard.Clear
.LB_CertificateExpired.Clear
End With
End Sub
'----
![](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)
