Garder les couleurs des cellules macro exporter
y
bonjour ,
Dans la macro ci jointe peut-on garder les couleurs des cellules lors de l'export vers les onglets ?
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Long 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Set OS = Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
TV = OS.Range("A1:J" & Cells(65536, 1).End(xlUp).Row) 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
D(TV(I, 1)) = "" 'alimente le dictionnaire avec la donnée en colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire TMP
On Error Resume Next 'gestionndes erreurs (en cas d'erreur passe à la ligne suivante)
Set OD = Worksheets(TMP(J)) 'définit l'onglet de destination OD (génère une erreur si cet onglet n'existe pas)
If Err <> 0 Then 'condition : si une erreur a été générée
Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position
Set OD = ActiveSheet 'définit l'onglet OD
OD.Name = TMP(J) 'renomme l'onglet OD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
OD.Cells.ClearContents 'efface toutes les cellules de l'onglet OD (au cas où l'onglet existait déja))
OD.Range("A1").Resize(1, UBound(TV, 2)).Value = Application.Index(TV, 1) 'renvoie en A1 redimensionnée, la ligne de titre (la ligne 1 du tableau des valeurs TV)
K = 1: Erase TL 'initialise la variable K, efface le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
If TV(I, 1) = TMP(J) Then 'si la donnée ligne I colonne I est égale à la donnée TMP(J)
ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
For L = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les colonne de TV
TL(L, K) = TV(I, L) 'récupère en ligne L de TL la donnée en colonne L de TV (=> transposition)
Next L 'prochaine colonne de la boucle 3
K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 2
With OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1))
.NumberFormat = "@"
.Value = Application.Transpose(TL) 'renvoie dans A2 redimensionné de l'onglet OD, le tab;eau TL transposé
End With
Next J 'prochaien élément de la boucle 1
End Sub
merci d'avance
bonjour Yoda60, avec une matrice, on n'est pas capable à conserver les couleurs ...
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Long 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Set OS = Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
TV = OS.Range("A1:J" & Cells(65536, 1).End(xlUp).Row) 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
D(TV(I, 1)) = "" 'alimente le dictionnaire avec la donnée en colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
With OS
If .AutoFilterMode Then .AutoFilterMode = False
With .Range("A1").CurrentRegion
For J = 0 To UBound(TMP)
.AutoFilter 1, TMP(J)
.Copy
Sheets.Add after:=Sheets(ActiveWorkbook.Sheets.Count)
On Error Resume Next 'pour le cas où ce nom existe déjà
ActiveSheet.Name = CStr(TMP(J))
On Error GoTo 0
ActiveSheet.Paste
Next
End With
.AutoFilterMode = False
End With
End Sub
y
impec merci BsAlv !