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

[laurent950]

Bonsoir le Forum,

Je cherche depuis pas mal de temps à intégrer des Format (Texte ou couleur cellule ou autres) dans une variable tableau sans passer par des procédures mais cela mais impossible est en fait après pas mal de recherche je ne sais pas trop mais il me semble que sur le site de BoisGontier il arrive à intégrer un format a une variable tableau mais je ne sais pas reproduire.
J’ai trouvé une astuce pour formater les cellules qui m’intéresse dans une boucle en même temps que je remplis ma variable tableau sauf :
- Que les cellules sont formater avant le résultat car le résultat est restitué à la fin en une fois j’aimerais faire en une seul fois cette action sans passer par une procédure.

J’envoie un code très simple de variable tableau et j’aimerais savoir si une personne a la solution pour remplacer la procédure pour la couleur pour faire tous en un seul passage de boucle est une seul restitution :
Code :

 ' Module (Macro)


Sub TabCouleur()

Dim T() As Variant
Dim F1 As Worksheet
Set F1 = ThisWorkbook.Worksheets("Feuil1")

' Efface les valleur de la feuilles
Range("B3:C18").ClearContents

' Efface les couleurs
    lign = 3
    col = 3
SansCouleur F1, lign, col

' Tableau
T = Range("A3:A18").Value
pos = Range("a3").Row

' Redimenion du tableau soit deux colonne supplémentaire
ReDim Preserve T(1 To 16, 1 To 3)

' Boucle
For i = 1 To UBound(T, 1)
    If T(i, 1) = "F" Then
        T(i, 2) = T(i, 1)
        T(i, 3) = "Sans couleur"
    ElseIf T(i, 1) = "y" Then
        T(i, 2) = T(i, 1)
        ' Procédure de mise en couleur
        lign = i + 2
        col = 2
        Resi = 2
        AvecCouleur F1, lign, col, Resi
        T(i, 3) = "Couleur"
    End If
Next i
        
' Colle version 1
'F1.[B3].Resize(UBound(T, 1), UBound(T, 2)) = T

' Mieux
For i = 2 To 3
     F1.Cells(3, i).Resize(UBound(T, 1)) = Application.Index(T, , i)
 Next i
 
' efface tous le Tableau T()
Erase T

Cells(1, 1).Select

End Sub

' ______________________________________________________________________________________________________

' Procédure Module (Couleur)


Sub AvecCouleur(ByVal F1, lign, col, Resi)
' Procedure (Renvois pas de resultat)

' faux Avec Souleur
    F1.Cells(lign, col).Resize(, Resi).Select
    With Selection
        .Font.Name = "Calibri"
        .Font.FontStyle = "Gras"
        .Font.Size = 11
        .Font.Underline = xlUnderlineStyleNone
        .Font.Color = 255
        .Font.ThemeFont = xlThemeFontMinor
        '.Borders(xlDiagonalDown).LineStyle = xlContinuous
        '.Borders(xlDiagonalUp).LineStyle = xlContinuous
        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 65535
    End With
    
End Sub
Sub SansCouleur(ByVal F1, lign, col)
' Procedure (Renvois pas de resultat)

' Sans Couleur
    F1.Range(F1.Cells(lign, 2), F1.Cells(18, col)).Select
    With Selection
        .Font.Name = "Calibri"
        .Font.FontStyle = "Normal"
        .Font.Size = 11
        .Font.Underline = xlUnderlineStyleNone
        .Font.ColorIndex = xlAutomatic
        .Font.ThemeFont = xlThemeFontMinor
        '.Borders(xlDiagonalDown).LineStyle = xlNone
        '.Borders(xlDiagonalUp).LineStyle = xlNone
        .Interior.Pattern = xlNone
    End With
    
End Sub

PS : Pour ceux qui aurais vu se code il se trouve aussi sur cette page c’était pour finalisé :
-
- Avec les codes palettes couleurs Excel
- Color Palette and the 56 Excel ColorIndex Colors

En page 3 =>>> Poste 31

Je voulais ouvrir un nouveau poste pour une vrais solution qui est encore non trouver pour ma part a ce jour.
Au plaisir de partager avec vous ce poste est peux être que cette astuce en sera pour certain qui ne sont pas encore des pros comme ceux qui m’ont déjà répondu sur ce forum est que je salut.

Laurent

 

[laurent950]

Bonsoir Patrick,
c'est vrais c'est plutôt tableau de données de format que j'essaie de récupérer a travers une variable Objet et de stocker dans une variable tableau se qui m'interresse en paramétre.

C'est a dire dans une plage Range : Rcuperer (La couleur de fond) / (couleur du texte) / (Les hauteurs de lignes) et d'autre choses encore et de stocker cela dans une variable tableau afin de réutilisé :

exemple : B4 / C2 / C5

dim Plg as Range
Set plg = Range(cells(1,1),cells(6,3)) ' L'objet Plage

Mais je ne sais pas lire, je cherche les collections ou les Module de classe (Enfin l'explication de tous cela) mais impossible a trouver même sur developpez.com

Merci patrick

 

[patricktoulon]

re
bonsoir laurent
perso j'utiliserait un dico
la cle = l'adresse et l'item = toute les propriété que tu veux memoriser separé par un caracteres particulier

pour les ressortir
tu utilise les données dans l'item
besoins
object scripting dictionary
fonction split


un tout petit exemple

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

-----------------------------------------------------------------------------------------
autre solution
on pourrait utiliser un bloc type avec toute les propriété voulue avec un tableau de type
et indexer les le tableau .ligne et .column
exemple A1 serait tab(11)'ligne1 colonne1

un peu comme ceci

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

 

[laurent950]

Merci patrick,
je pense que tu es encore plus fort que fort, non franchement c'est magnifique comment tu jongles avec le code, c'est propre et vraiment précis j'adore. Merci a patricktoulon de m'avoir aider à créer ce fichier que j'ai poster en Poste #16 pour en garder une trace par rapport a mes exemples et se que j'ai noté.
C'est vraiment extra cela fait si longtemps que je cherche une solution et hop tu as trouvé à la vitesse de l'éclair.

Ps : Le fichier Poste #16 est réalisé grace à Patricktoulon (ce fichier à pu être créer uniquement et grace à la solution du code de patricktoulon en poste #17 qui est sa solution résolu à mon probléme posé en Poste #16)

Un très grand merci Patrick

 

[laurent950]

Complément,
Tableau 1 dimension contenant un tableau 2D
TresBanque(1) ' contenant un tableau 2D
TresBanque(2) ' contenant un tableau 2D
TresBanque(3) , contenant un tableau 2D
'MsgBox TresBanque(3)(1, 1) ' Celulle
'MsgBox LBound(TresBanque(3)) ' Dimension tableau 1 D (Plus petite)
'MsgBox UBound(TresBanque(3)) ' Dimension tableau 1 D (plus Grande)
'MsgBox UBound(TresBanque(3), 1) ' Nombres de lignes
'MsgBox UBound(TresBanque(3), 2) ' Nombre de colonne

Variables tableaux Multidimension
exemple ci dessous :
Option Base 1
Dim TresBanque() As Variant
ReDim TresBanque(1)
Boucle For i
TresBanque(UBound(TresBanque)) = FBanque.Range(FBanque.Cells(i + 19, 1), FBanque.Cells(i + 19, 15))
ReDim Preserve TresBanque(UBound(TresBanque) + 1)
Next i
' Suppression de la derniére ligne inutile
ReDim Preserve TresBanque(UBound(TresBanque) - 1)
' Restitution de se tableau multidimension
For i = LBound(TresBanque, 1) To UBound(TresBanque, 1)
Me.Cells(i + 3, 1).Resize(UBound(TresBanque(i), 1), UBound(TresBanque(i), 2)) = TresBanque(i)
Next i

 

[laurent950]

Détail :
1 tableau (1 dimension)
* Chacune des cases contient une ligne soit un tableau 1 dimension aussi
* Tris de chacune des lignes
* Par ordres Croissant / option Décoissant
* Restitution du Tableau 1 dimension pour chacune des lignes
* Code ci-dessous / avec fichier excel pour mémoire

il faut juste faire un Tri d’un tableau (Array) à 1 dimension
Le coeur du programme est simple pour le reste c'est le principe du tri quickSort

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

La fonction de tri

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

Lien : http://boisgontierjacques.free.fr/

Multi tableau 2 D en une seul fois
dim NewArray as Variant
NewArray = Activesheet.Evaluate("D4:I9*D12:I12") ' Multiplage !

Multiply a 2D array by 1D array to get a third (2D) array

I've working with three dynamic arrays (all are datatype Double) - they are OriningalArray This will be assigned from a range that the end user will see and will be 2 dimension MultiplierArr...

codereview.stackexchange.com

Complément

VBA Tutorial => Multidimensional Arrays

Learn VBA - Multidimensional Arrays

riptutorial.com

Microsoft 365 - Indices Tableau à 2 dimensions ( VBA )

Bonjour tout le monde, Je pensais que c'était "basique", ben non, ou, une fois encore le "neuneu" qui dort en moi a sévi ! A partir d'un 1er tableau de 4 lignes et 10 colonnes dans lequel toutes les cellules ne sont pas renseignées, je créé des "sous-tableaux" de façon à avoir pour chaque...

www.excel-downloads.com

Microsoft 365 - Comment récupérer l'adresse d'une cellule dans une variable tableau ?

Bonjour, Dans une variable tableau, je cherche à récupérer l'adresse d'une cellule contenant en fonction de sa valeur. Ex. avec les nombres ci-dessous de A1 à D10 Si la somme des col. A + B est > C + D -> récupération de l'adresse (pas sur la feuille Excel, mais dans la var tableau Tb)...

www.excel-downloads.com

 

[laurent950]

Exemple : Comment récupérer l'adresse d'une cellule dans une variable tableau.

l'astuce c'est :
* une tableau à 1 dimension qui contient 2 cases (0 et 1)
* Case 0 = on injecte les valeurs de la matrice
* Case 1 = on injecte la plage Range (L'objet)
* Donc les Positions relatif et Absolu sont contenu dans la variable tableau 1 Dimension mais qui contient deux Matrice (Une matrice avec que des valeurs et une matrice avec la plage range)
* Comment vous trouver cette Astuce ?

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

 

[laurent950]

Pour moi.

Je conserve un code Ecrit et établit par @patricktoulon qui est Extra
En Poste #5 (de la discussion ci-dessous)
Lien https://www.excel-downloads.com/thr...-tableau-dans-1-autre.20053235/#post-20397369
Merci @patricktoulon

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

Pour Moi : Tb = Application.Index(.Value, lignes, Array(1, 2, 5, 6))
Tb = Application.Index(tablo, lignes, Array(1, 2, 5, 6)) ' A Tester aussi

 

[patricktoulon]

re
allez pour faire un peu grincer des dents Laurent
je décide de travailler proprement sans bricolage de split de string avec un redim lignes dynamique

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

comme chez renault c'est simple

 

[laurent950]

Re @patricktoulon
un grand merci patrick pour ce code magnifique, je viens de découvrir un peut plus
avec ces Options Application.Index et Application.Transpose
Surtout sur le choix des combinaisons multiples de lignes et colonnes avec des variables tableaux
lignes : Les Lignes discontinues (Plusieurs choix)
Array : Les colonnes discontinues (Plusieurs choix)
Un Grand merci Patrick
Laurent

 

[patricktoulon]

re
de rien mais je t'avais déjà expliqué tout ça me semble t il hein !!!! je t'ai même fait un pdf je crois non ?

Tb = Application.Index(tableau entier , tableau vertical (2dim) , tableau horizontal(1 dim))

Tb = Application.Index(tablo, 1, Array(1, 2, 5, 6))
' ------------------------------- 3
' ------------------------------- 6

 

[laurent950]

Re @patricktoulon
Oui c'est vrai j'ai conservé tout ce que tu m'as offert pour que je puisse m'améliorer.
J'ai tout compris, sauf que j'avais oublié cette astuce avec :
Tb = Application.Index(tableau entier , tableau vertical (2dim) , tableau horizontal(1 dim))
Pour les colonnes je savais, mais pour les Lignes j'y étais plus
Cela me fait un tout petits rappelle pour le reste j'ai retenu
Vraiment je te remercie Patrick
Je vais me remettre sur mon projet avec ce méga userform (Index BT et TP) que l'on a commencé a construire ensemble en mars (Je tiens aussi à te remercier pour cela, toute cette aide apporté aussi)
Je vais mis remettre
Laurent

 

[patricktoulon]

re
pas de soucis
mais là encore me semble t il que je t'avais donné une version qui était aboutie et qui avait réduit ton code de près de 80% avec l'utilisation d'une combo caché ou pas
bref ouvre un post si tu veux aller plus loinsur ton projet ( je regarderais)
ici c'est un autre sujet

 

[laurent950]

Merci @patricktoulon
Je vais en créé un Poste dédié quand je vais me remette dessus.