Variable Tableau & Format (Et Restitution Du Résultat En Une Seul Fois)

Sub test()
    Dim mesFormat As Object    'latebinding car le dico sera créé dans la fonction
    Dim forme    ' sera un tableau par le split du texte d'un item pa rapport a sa clé
    Set mesFormat = conserveFormatrange(Range("A1:C10"))
     'on teste
   forme = Split(mesFormat("B3"), "|")    'on split le texte de l'item du dico(23)
   MsgBox "la couleur de fond de b3 est " & forme(3)
End Sub



Function conserveFormatrange(rng) As Object
    Dim dico As Object, cel As Range
    Set dico = CreateObject("scripting.dictionary")
    For Each cel In rng.Cells
        With cel
            dico(.Address(0, 0)) = .Font.Color & "|" & .Font.Name & "|" & .Font.Size & "|" & .Interior.Color
            'etc... etc.....
        End With
    Next
    Set conserveFormatrange = dico    'lafonction retourne le dico dans sa totalité
    'il est decanté dans la sub par et avec  "forme"
End Function

Public Type formats
    adresse As String
    fontColor As Long
    fontName As String
    fontSize As Long
    bolder As Boolean
    italik As Boolean
    interiorColor As Long
    'etc...etc....
End Type
Dim mesformat(2000) As formats     

Sub test()
     conserveFormatrange2 Range("A1:C10")
    'on teste
    Set cel = [B3]
    MsgBox mesformat(Val(cel.Row & cel.Column)).interiorColor
End Sub

Function conserveFormatrange2(rng)
    For Each cel In rng.Cells
        With mesformat(Val(cel.Row & cel.Column))
            .adresse = cel.Address(0, 0)
            .fontColor = cel.Font.Color
            .fontName = cel.Font.Name
            .fontSize = cel.Font.Size
            .interiorColor = cel.Interior.Color
            'etc... etc.....
        End With
    Next
End Function

Sub MiseEnForme()
Dim t() As Variant, i As Integer, j As Integer
ReDim t(1)
For i = 7 To ActiveSheet.Cells(ActiveSheet.Cells(65535, 3).End(xlUp).Row, 3).Row
    t(i - 6) = Range(Cells(i, 3), Cells(i, 7))
    tri t, i - 6, LBound(t(1), 2), UBound(t(1), 2)
    ReDim Preserve t(UBound(t) + 1)
Next i
' Restitution de se tableau multidimension
ReDim Preserve t(UBound(t) - 1)
For i = LBound(t, 1) To UBound(t, 1)
Cells(i + 6, 9).Resize(UBound(t(i), 1), UBound(t(i), 2)) = t(i)
Next i
End Sub

Sub tri(a() As Variant, i, gauc, droi) ' Quick sort
   ref = a(i)(1, (gauc + droi) \ 2)
   g = gauc: d = droi
   Do
     ' Pour un tri Croissant
      Do While a(i)(1, g) < ref: g = g + 1: Loop
      Do While ref < a(i)(1, d): d = d - 1: Loop
        If g <= d Then
           temp = a(i)(1, g): a(i)(1, g) = a(i)(1, d): a(i)(1, d) = temp
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri(a, i, g, droi)
    If gauc < d Then Call tri(a, i, gauc, d)
End Sub

'Pour un tri décroissant
'Do While a(i)(g, colTri) > ref: g = g + 1: Loop
'Do While ref > a(i)(d, colTri): d = d - 1: Loop

Sub test()
Dim FD As Worksheet
    Set FD = Worksheets("Feuil1")
Dim TbBis(1 To 2) As Variant
        TbBis(1) = FD.Range("F18:I" & FD.Range("F999999").End(xlUp).Row).Value
    Set TbBis(2) = FD.Range("F18:I" & FD.Range("F999999").End(xlUp).Row)
    For i = LBound(TbBis(1), 1) To UBound(TbBis(1), 1)
        If TbBis(1)(i, 1) + TbBis(1)(i, 2) > TbBis(1)(i, 3) + TbBis(1)(i, 4) Then
            'TbBis(2)(i, 1).Select: MsgBox TbBis(1)(i, 1)
            'TbBis(2)(i, 2).Select: MsgBox TbBis(1)(i, 2)
            s = s & vbLf & Space(11) & TbBis(2)(i, 1).Address(0, 0) & " à " & TbBis(2)(i, 2).Address(0, 0)
        End If
    Next i
    MsgBox s
' Libére la mémoire
    Erase TbBis
    Set FD = Nothing
    Calc1 = Empty: Calc2 = Empty
End Sub

Option Explicit
Sub Tableau()
    Dim Tb, I&, tablo, it as String, lignes as Variant
    With Feuil1.Range("A2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
        tablo = .Value
        For I = 1 To UBound(tablo)
            If tablo(I, 5) = "A" Or tablo(I, 5) = "C" Then
                 ' It = Chaîne de caractères
                 ' It = Les lignes qui rentre dans la condition
                 ' It = Exemple de résultats par concaténations / donc      It =  " 1 4 6 9 12 14"
                            it = it & " " & I
            End If
        Next
        ' lignes devient une variable tableau 2D (1 To N lignes, 1 To 1)
          lignes = Application.Transpose(Split(Trim(it), " "))
        ' Donc application. Index
        ' .Value = Feuil1.Range("A2:F" & Cells(Rows.Count, 1).End(xlUp).Row).Value
        ' lignes = Les lignes a conserver soit It =  " 1 4 6 9 12 14" Transposé dans la Var Tab 2D lignes
        ' Array  = Le choix des colonnes a conserver
        Tb = Application.Index(.Value, lignes, Array(1, 2, 5, 6))
    End With
    [H2].Resize(UBound(Tb), UBound(Tb, 2)) = Tb
End Sub

Option Explicit

Sub Tableau()
    Dim Tb, I&, tablo, it, lignes(), a&
    With Feuil1.Range("A2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
        tablo = .Value
        For I = 1 To UBound(tablo)
            If tablo(I, 5) = "A" Or tablo(I, 5) = "C" Then a = a + 1: ReDim Preserve lignes(1 To a): lignes(a) = I
        Next
        Tb = Application.Index(tablo, Application.Transpose(lignes), Array(1, 2, 5, 6))
    End With
    [H2].Resize(UBound(Tb), UBound(Tb, 2)) = Tb
End Sub