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

laurent950

XLDnaute Accro
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 :

VB:
 ' 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
 

Pièces jointes

  • CouleurTableaux&Procedure.xlsm
    28.6 KB · Affichages: 63
  • CouleurTableaux&Procedure.xlsm
    28.6 KB · Affichages: 64
  • CouleurTableaux&Procedure.xlsm
    28.6 KB · Affichages: 62
Dernière édition:

laurent950

XLDnaute Accro
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
1579893150158.png


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

1579893388938.png


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
 

Pièces jointes

  • Var Tab et Objet conserveFormatrange.xlsm
    16 KB · Affichages: 2
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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
VB:
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
VB:
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
;)
 
Dernière édition:

laurent950

XLDnaute Accro
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

XLDnaute Accro
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

XLDnaute Accro
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

VB:
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
VB:
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

VB:
'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 !


Complément
 

Pièces jointes

  • QuickSortOrdreCroissantVariableTableau.xlsm
    23.8 KB · Affichages: 3
Dernière édition:

laurent950

XLDnaute Accro
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 ?

1590087561520.png

VB:
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
 
Dernière édition:

laurent950

XLDnaute Accro
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

VB:
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
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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
VB:
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

XLDnaute Accro
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

XLDnaute Barbatruc
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

XLDnaute Accro
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

XLDnaute Barbatruc
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 ;)
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 011
Membres
101 866
dernier inscrit
XFPRO