XL 2021 Macro dans Macro

Dranreb à dit:

Remarquez: il serait possible de sélectionner les étiquette surlignées afin de pouvoir les parcourir par touche Tab :

VB:

Sub IdentifierPointsCollecte()
   Dim ClnEtq As Collection, Cel As Range, RngA As Range, L As Long, RngSel As Range
   Set ClnEtq = New Collection
   For Each Cel In Feuil5.UsedRange
'      If VarType(Cel.Value) = vbString And IsNumeric(Mid$(Cel.Value, 2)) Then Cel.MergeArea.Style = "EtqNorm"
      If Cel.Style Like "Etq*" And Not IsEmpty(Cel.Value) Then
         ClnEtq.Add Item:=Cel, Key:=Cel.Value
         Cel.MergeArea.Style = "EtqNorm"
         End If
      Next Cel
   T = [t_ListeCourses[[CHOIX (x)]:[Localisation]]].Value
   For L = 1 To UBound(T, 1)
      If Not IsEmpty(T(L, 1)) Then
         On Error Resume Next
         Set Cel = ClnEtq(T(L, 2))
         If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn": If RngSel Is Nothing _
            Then Set RngSel = Cel.MergeArea Else Set RngSel = Union(RngSel, Cel.MergeArea)
         On Error GoTo 0
         End If
      Next L
   Application.Goto RngSel
'   For Each RngA In [t_ListeCourses[Localisation]].SpecialCells(xlCellTypeVisible).Areas
'      If RngA.Rows.Count = 1 Then
'         ReDim T(1 To 1, 1 To 1): T(1, 1) = RngA.Value
'      Else: T = RngA.Value: End If
'      For L = 1 To UBound(T, 1)
'         If Not IsEmpty(T(L, 1)) Then
'            On Error Resume Next
'            Set Cel = ClnEtq(T(L, 1))
'            If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn"
'            On Error GoTo 0
'            End If
'         Next L, RngA
   End Sub

Cliquez pour agrandir...