XL 2016 Trie d'information dans des cellules

[Bambi35]

Bonjour a tous
Je viens vers vous pour de l'aide.
Je cherche à répartir les informations de la Feuille "Base" sur la Feuille "Colonnes1" en passant par du VBA

Sur le Base j'ai CRO en"A2" et P,E,T sur "B2"
et PAT en"A3" et O sur "B3"
etc...

sur le Feuille "Colonne1 avoir
CRO en"A2" et P sur "B2"
CRO en"A3" et E sur "B3"
CRO en"A4" et T sur "B4"
PAT en"A5" et O sur "B5"
etc...

Je vous ai déjà demandé il y a quelque temps mais je m'arrive pas à modifier le VBA, et J'aimerai n'avoir que ce code sur cette feuille.


Merci de votre aide


Bambi35

 

[vgendron]

Hello
un test ici

Sub dispatch()
Dim TabData() As Variant

With Sheets("Base")
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row 'derniere ligne sur la colonne A
    TabData = .Range("A2:C" & Fin).Value
End With

Col = 1
With Sheets("Colonne1")
    .UsedRange.Offset(1, 0).ClearContents
    For i = LBound(TabData, 1) To UBound(TabData, 1)
        nbligne = UBound(Split(TabData(i, 2), ",")) + 1
        If nbligne = 0 Then
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
        Else
            For k = 1 To nbligne
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = Split(TabData(i, Col + 1), ",")(k - 1)
            Next k
        End If
    Next i
End With

Col = 2
With Sheets("Colonne2")
    .UsedRange.Offset(1, 0).ClearContents
    For i = LBound(TabData, 1) To UBound(TabData, 1)
        nbligne = UBound(Split(TabData(i, 3), ",")) + 1
        If nbligne = 0 Then
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
        Else
            For k = 1 To nbligne
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = Split(TabData(i, Col + 1), ",")(k - 1)
            Next k
        End If
    Next i
End With
End Sub

 

[vgendron]

la meme en condensé

Sub dispatch()
Dim TabData() As Variant

With Sheets("Base")
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row 'derniere ligne sur la colonne A
    TabData = .Range("A2:C" & Fin).Value
End With

For col = 1 To 2
    NomFeuille = "Colonne" & col
    With Sheets(NomFeuille)
        .UsedRange.Offset(1, 0).ClearContents
        For i = LBound(TabData, 1) To UBound(TabData, 1)
            nbligne = UBound(Split(TabData(i, col + 1), ",")) + 1
            If nbligne = 0 Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
            Else
                For k = 1 To nbligne
                    .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabData(i, 1)
                    .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1) = Split(TabData(i, col + 1), ",")(k - 1)
                Next k
            End If
        Next i
    End With
Next col

End Sub

 

[Bambi35]

Bonsoir Vgendron

Merci pour ton retour.je regarde ce soir.
Merci encore
Je te tiens au courant
Bambi35

 

[Bambi35]

Bonsoir Vgendron
Merci pour ton code
j'ai pris le premier pour mieux comprendre , mais peux-tu mettre des commentaires concernant le code car j'ai voulus rajouter une colonne D en plus sur la Base.
j'ai recopier le code de la colonne2 en changent Col=3 et With Sheets("Colonne3")
Que dois-je changer

Merci encore de ton aide

 

[vgendron]

il faut aussi changer ces lignes
TabData = .Range("A2:C" & Fin).Value
nbligne = UBound(Split(TabData(i, 3), ",")) + 1

qui deviennent
TabData = .Range("A2" & Fin).Value
nbligne = UBound(Split(TabData(i, 4), ",")) + 1

 

[Bambi35]

Vgendron
Merci pour ton aide.
Je vais le noté dans le code

Merci
@++
Bambi35

 

[Bambi35]

Bonjour Vgendron
Le résultat est nickel mais je reviens vers toi car j'ai vu qu'il me manquait une info dans la cellule "B2" de la Feuille "Base"
Chaque Informations est composé de : X ; Y et non de X seulement
CRO en"A2" et P;Jaune,E;Bleu,T;noir sur "B2"
etc...
Seule le texte avant " ; "doit apparaitre sur le Feuille "Colonne1

sur le Feuille "Colonne1 avoir
CRO en"A2" et P sur "B2"
CRO en"A3" et E sur "B3"
CRO en"A4" et T sur "B4"
etc...
Comment modifier le VBA pour avoir ce résultat

Merci d'avance


Bambi35

 

[job75]

Bonjour Bambi35, vgendron, le forum,

Voyez le fichier joint et cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim col%, nlig&, resu(), tablo, i&, nom$, s, ub%, j%, n&, x$, p%
col = Val(Replace(LCase(Sh.Name), "colonne", ""))
If col = 0 Then Exit Sub
col = col + 1
With Sheets("Base").[A1].CurrentRegion
    tablo = .Resize(, col) 'matrice, plus rapide
    .Columns(col).Name = "Colonne" 'plage nommée
    nlig = .Rows.Count + [SUM(LEN(Colonne)-LEN(SUBSTITUTE(Colonne,",",)))]
End With
ReDim resu(1 To nlig, 1 To 2) 'tableau des résultats
For i = 1 To UBound(tablo)
    nom = tablo(i, 1)
    s = Split(tablo(i, col), ",")
    ub = UBound(s)
    If ub = -1 Then n = n + 1: resu(n, 1) = nom
    For j = 0 To ub
        n = n + 1
        resu(n, 1) = nom
        x = Trim(s(j))
        p = InStr(x, ";")
        If p Then x = RTrim(Left(x, p - 1)) 'texte avant le point-virgule
        resu(n, 2) = x
Next j, i
'---restitution---
With Sh.[A1] '1ère cellule de restitution
    .Resize(n, 2) = resu
    .Offset(n).Resize(Sh.Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Elle s'exécute quand on active les feuilles Colonne1, Colonne2, etc...

Elle tient compte de la dernière demande (l'histoire des points-virgules).

Elle est très rapide car tous les traitements se font sur des tableaux VBA et les résultats sont restitués en une seule fois dans les cellules.

A+

 

[job75]

Pour tester j'ai recopié le tableau A2:C7 de la feuille "Base" sur 12 000 lignes.

La macro du post #3 (sur la feuille "Colonne1" seulement) s'exécute chez moi en 17 secondes.

La macro du post #9 s'exécute en 0,17 seconde, elle est donc 100 fois plus rapide.

 

[Bambi35]

Bonjour merci je regarde ce soir

Bambi35

 

[vgendron]

Bonjour Bambi35

Je ne comprends pas du tout de quoi tu parles avec les infos de couleur?? ca apparait où dans ton fichier??
Hello Job75

 

[job75]

Je ne comprends pas du tout de quoi tu parles avec les infos de couleur?? ca apparait où dans ton fichier??

Jaune, bleu, noir sont des textes quelconques séparés par des points-virgules.

Dans mon fichier j'ai mis AAA BBB CCC.

Bambi35 veut qu'ils ne soient pas copiés.

 

[Bambi35]

Jaune, bleu, noir sont des textes quelconques séparés par des points-virgules.

Dans mon fichier j'ai mis AAA BBB CCC.

Bambi35 veut qu'ils ne soient pas copiés.

 

[Bambi35]

Bonjour
Oui les couleurs sont du texte quelconques comme la lettre avant le ;

Bambi