Microsoft 365 VBA: Réorganiser les données

VBA_dev_Anne_Marie · 31 Juillet 2022

Bonjour,
Je n'arrive pas à trouver une méthode pour réorganiser mes données en VBA :
Mon tableau en entrée est :

Je voudrais avoir ce tableau en sortie (dans la première colonne je ne garde que des observations majoritaires : j'ai 4 lignes pour N1 et 2 lignes pour N2, je ne garde que les N1) :

Merci pour votre aide !

VBA_dev_Anne_Marie · 6 Septembre 2022

dysorthographie à dit:

Bonjour,
je suis pas certain d'avoir tout compris!

VB:

Sub transpose()
Dim Lib As String, L As Integer
Worksheets("feuil2").UsedRange.ClearContents
With Worksheets("feuil1").Range("A1").CurrentRegion
    col = 0
    nom = .Cells(1, 1)
    For x = 1 To .Rows.Count
        If Not CBool(InStr(1, Lib, "©" & .Cells(x, 2) & "©")) Then
            col = col + 1
            Sheets("feuil2").Range("A1").Offset(, col) = .Cells(x, 2)
            Lib = Lib & "©" & .Cells(x, 2) & "©"
        End If
       
        If nom = .Cells(x, 1) Then
            Sheets("feuil2").Range("A2").Offset(L) = nom
            L = L + 1
        End If
    Next
End With
End Sub

Bonjour,

Est-ce que je peux partir de ce code pour faire la transformation de ce genre, s'il vous plaît ?

NOM1	AA1	12	ML
NOM1	AA1	2	MP
NOM1	AA1	13	MC
NOM2	BB1	14	ML
NOM3	CC1	2	MC
NOM3	CC1	3	MP

Résultat :

		ML	MP	MC
NOM1	AA1	12	2	13
NOM2	BB1	14
NOM3	CC1		3	2

En fait, j'ai déjà commencé à retravailler le code :

VB:

Sub transpose_bis()
Dim Lib As String, L As Integer, lig, e As Integer
Worksheets("Supports_resultats").UsedRange.ClearContents
With Worksheets("Supports").Range("D11").CurrentRegion
    Col = 0
    ligne = 0
    nom = .Cells(1, 1)
    For x = 1 To .Rows.Count
        If Not CBool(InStr(1, Lib, "©" & .Cells(x, 1) & "©")) Then
            Col = Col + 1
            ligne = ligne + 1
            Sheets("Supports_resultats").Range("A1").Offset(, Col + 1) = .Cells(x, 4)
            Lib = Lib & "©" & .Cells(x, 2) & "©"
             Sheets("Supports_resultats").Range("A2") = .Cells(x, 1)
             Sheets("Supports_resultats").Range("B2") = .Cells(x, 2)
        End If
        
    End If
    Next
      
End With
End Sub

Je me demande s'il vaut mieux utiliser les array pour ce genre de besoin.

Merci pour votre aide !

VBA_dev_Anne_Marie · 12 Septembre 2022

VBA_dev_Anne_Marie à dit:
Bonjour,

Est-ce que je peux partir de ce code pour faire la transformation de ce genre, s'il vous plaît ?

NOM1 AA1
12
ML
NOM1 AA1
2
MP
NOM1 AA1
13
MC
NOM2 BB1
14
ML
NOM3 CC1
2
MC
NOM3 CC1
3
MP

Résultat :

ML MP MC
NOM1 AA1
12
2
13
NOM2 BB1
14
NOM3 CC1
3
2

VB:

Sub Transpose()

On Error Resume Next
Sheets("TABLEAU").ShowAllData
On Error GoTo 0

Sheets("TABLEAU").Cells.ClearContents
Sheets("TABLEAU").Range("ISIN").Value = "ISIN"
Sheets("TABLEAU").Range("LIBELLE").Value = "LIBELLE"
Dim Fin, tabInit, CodeExiste, TypeExiste, ColPos, FinType
Dim DebCode As Integer, FinCode As Integer, DebType As Integer, i As Integer, LinePos As Integer


With Sheets("BDD") 'récupère les données
    Fin = .Range("D" & .Rows.Count).End(xlUp).Row
    tabInit = .Range("D11:G" & Fin).Value
End With

DebCode = 5
FinCode = 5
DebType = 5
FinType = 5

With Sheets("TABLEAU")
    For i = LBound(tabInit, 1) To UBound(tabInit, 1) 'pour chaque ligne du tableau
        Set CodeExiste = .Range("C:C").Find(tabInit(i, 1)) 'on regarde si le code est déjà présent dans la colonne A
        If CodeExiste Is Nothing Then 's'il n'apparait pas..on l'ajoute en dessous
            .Range("C" & FinCode) = tabInit(i, 1)
            .Range("D" & FinCode) = tabInit(i, 2)
            LinePos = FinCode 'et on note la ligne de remplissage
            FinCode = FinCode + 1
        Else
            LinePos = CodeExiste.Row 'on note la ligne de remplissage
        End If
        
        Set TypeExiste = .Rows("4:4").Find(tabInit(i, 4)) 'idem pour la date sur la ligne 1
        If TypeExiste Is Nothing Then
            .Cells(4, FinType) = tabInit(i, 4)
             ColPos = FinType
            FinType = FinType + 1
        Else
            ColPos = TypeExiste.Column
        End If
        .Cells(LinePos, ColPos) = tabInit(i, 3) 'on met la quantité
        Sheets("TABLEAU").Cells(LinePos, ColPos).NumberFormat = "#,##0.00€"
    Next i
End With
End Sub

Merci pour vos suggestions !

VBA_dev_Anne_Marie à dit:

En fait, j'ai déjà commencé à retravailler le code :

VB:

Sub transpose_bis()
Dim Lib As String, L As Integer, lig, e As Integer
Worksheets("Supports_resultats").UsedRange.ClearContents
With Worksheets("Supports").Range("D11").CurrentRegion
    Col = 0
    ligne = 0
    nom = .Cells(1, 1)
    For x = 1 To .Rows.Count
        If Not CBool(InStr(1, Lib, "©" & .Cells(x, 1) & "©")) Then
            Col = Col + 1
            ligne = ligne + 1
            Sheets("Supports_resultats").Range("A1").Offset(, Col + 1) = .Cells(x, 4)
            Lib = Lib & "©" & .Cells(x, 2) & "©"
             Sheets("Supports_resultats").Range("A2") = .Cells(x, 1)
             Sheets("Supports_resultats").Range("B2") = .Cells(x, 2)
        End If
       
    End If
    Next
     
End With
End Sub

Je me demande s'il vaut mieux utiliser les array pour ce genre de besoin.

Merci pour votre aide !

Bonjour,
J'ai utilisé ce code pour transposer le tableau, qu'est-ce que vous en penser :

Staple1600 · 12 Septembre 2022

Bonjour le fil

dysorthographie à dit:

Bonjour,
je t'es créé une méthode pour encadrer tes différentes plage

VB:

Sub Encadrement(Plage As Range)

    Plage.Borders(xlDiagonalDown).LineStyle = xlNone
    Plage.Borders(xlDiagonalUp).LineStyle = xlNone
    With Plage.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Plage.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Plage.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Plage.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Plage.Borders(xlInsideVertical).LineStyle = xlNone
    Plage.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

et voila commenonl'utilise

Code:

Encadrement range("B1:C1")

et voila le code aucomplet!

Code:

Enum d
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
End Enum
Sub transpose()
Sheets("feuil2").Cells.Delete
Dim Obj As Object, Nb As Object: Set Obj = CreateObject("ADODB.Recordset"): Set Nb = CreateObject("ADODB.Recordset")    'on creer la collection
Obj.Fields.Append "Name", adChar, 50
Obj.Open
Nb.Fields.Append "Name", adChar, 50
Nb.Fields.Append "NB", adInteger, 4
Nb.Open
Dim Lib As String, L As Integer
Worksheets("feuil2").UsedRange.ClearContents
With Worksheets("feuil1").Range("A1").CurrentRegion
    col = 0
    nom = .Cells(1, 1)
    For X = 1 To .Rows.Count
        If Not CBool(InStr(1, Lib, "©" & .Cells(X, 2) & "©")) Then
            col = col + 1
            Sheets("feuil2").Range("A1").Offset(, col) = .Cells(X, 2)
            Lib = Lib & "©" & .Cells(X, 2) & "©"
        End If
        Obj.AddNew                                              'on ajoute un enregistrement à la collection
        Nb.Filter = "Name='" & Replace(.Cells(X, "A"), "'", "''") & "'"
        If Nb.EOF Then Nb.AddNew
        Obj("Name") = .Cells(X, "A"): Nb("Name") = .Cells(X, "A")
        Nb("NB") = Nb("NB") + 1
        Obj.Update: Nb.Update
        Nb.Filter = ""
        Obj.MoveFirst: Nb.MoveFirst
        Nb.Sort = "NB Desc"
    Next
End With
Obj.Filter = "Name='" & Replace(Nb("Name"), "'", "''") & "'"
If Not Obj.EOF Then Sheets("feuil2").Range("A2").CopyFromRecordset Obj
With Sheets("feuil2").Range("A2").CurrentRegion
   Encadrement .Range(.Range("B1"), .Cells(1, .Columns.Count))
   For i = 1 To .Columns.Count
     Encadrement .Range(.Cells(2, i), .Cells(.Rows.Count, i))
   Next
   .EntireColumn.AutoFit
End With
End Sub
Sub Encadrement(Plage As Range)

    Plage.Borders(xlDiagonalDown).LineStyle = xlNone
    Plage.Borders(xlDiagonalUp).LineStyle = xlNone
    With Plage.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Plage.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Plage.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Plage.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Plage.Borders(xlInsideVertical).LineStyle = xlNone
    Plage.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

[aparté]
Pour l'encadrement, je me permets cet petit one-liner

VB:

Sub Tests()
Range("B1:C5").Clear
'trois exemples de syntaxes possibles
Encadrement Range("B1:C1")
Encadrement Range("B3:C3"), xlThick
Encadrement Range("B5:C5"), 1
End Sub
Private Sub Encadrement(r As Range, Optional b As XlBorderWeight = xlMedium)
r.BorderAround , b
End Sub

Et pour la transposition, tout comme Hasco (que je salue au passage ), je suggère l'emploi de la Requête Puissante (AKA PowerQuery)

VBA_dev_Anne_Marie · 12 Septembre 2022

Staple1600 à dit:
Bonjour le fil

[aparté]
Pour l'encadrement, je me permets cet petit one-liner

VB:

Sub Tests() Range("B1:C5").Clear 'trois exemples de syntaxes possibles Encadrement Range("B1:C1") Encadrement Range("B3:C3"), xlThick Encadrement Range("B5:C5"), 1 End Sub Private Sub Encadrement(r As Range, Optional b As XlBorderWeight = xlMedium) r.BorderAround , b End Sub

Et pour la transposition, tout comme Hasco (que je salue au passage ), je suggère l'emploi de la Requête Puissante (AKA PowerQuery)

Bonjour Staple1600,
Merci pour l'encadrement.
Je voulais refaire le nouvel encadrement à chaque fois que je crée mon tableau mais la commande Sheets("BDD").Cells.ClearContents n'enlève pas l'encadrement.
Auriez-vous des idées comment le supprimer automatiquement avant de le récréer (en fait, le nombre de lignes de mon tableau change à chaque fois que je récupère les données).

Merci pour votre aide !

VBA_dev_Anne_Marie · 12 Septembre 2022

Staple1600 à dit:
Bonjour le fil

[aparté]
Pour l'encadrement, je me permets cet petit one-liner

VB:

Sub Tests() Range("B1:C5").Clear 'trois exemples de syntaxes possibles Encadrement Range("B1:C1") Encadrement Range("B3:C3"), xlThick Encadrement Range("B5:C5"), 1 End Sub Private Sub Encadrement(r As Range, Optional b As XlBorderWeight = xlMedium) r.BorderAround , b End Sub

Et pour la transposition, tout comme Hasco (que je salue au passage ), je suggère l'emploi de la Requête Puissante (AKA PowerQuery)

Est-ce que je peux utiliser la requête Power Query si le nombre de lignes dans ma table varie ? Auriez-vous des vidéos expliquant comment créer le TCD avec Power Query ?

Merci !

dysorthographie · 12 Septembre 2022

Bonjour,
ta demande initial à bien evolué!

VB:

Sub test()
Dim Horizontal As Object, Vertical As Object, i As Integer, C As Integer
C = 2
Sheets("Supports_resultats").Cells.Delete
Set Horizontal = CreateObject("Scripting.Dictionary"): Set Vertical = CreateObject("Scripting.Dictionary")
With Sheets("BDD").Range("A1").CurrentRegion
    For i = 1 To .Rows.Count
        If Not Horizontal.exists(.Cells(i, "D").Value) Then  C = C + 1: Horizontal(.Cells(i, "D").Value) = C
        If Not Vertical.exists(.Cells(i, "A").Value) Then Vertical(.Cells(i, "A").Value) = Sheets("Supports_resultats").Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1).Row
          Sheets("Supports_resultats").Cells(Vertical(.Cells(i, "A").Value), "A") = .Cells(i, "A").Value
          Sheets("Supports_resultats").Cells(Vertical(.Cells(i, "A").Value), "B") = .Cells(i, "B").Value
          Sheets("Supports_resultats").Cells(Vertical(.Cells(i, "A").Value), Horizontal(.Cells(i, "D").Value)) = .Cells(i, "C").Value
          Sheets("Supports_resultats").Cells(1, Horizontal(.Cells(i, "D").Value)) = .Cells(i, "D").Value
    Next
End With
v = Vertical.keys: h = Horizontal.keys
With Sheets("Supports_resultats")
  Encadrement .Range(.Cells(Vertical(v(0)), "A"), .Cells(Vertical(v(UBound(v))), Horizontal(h(UBound(h))))), xlMedium
  Encadrement .Range(.Cells(1, Horizontal(h(0))), .Cells(Vertical(v(UBound(v))), Horizontal(h(UBound(h))))), xlMedium
End With
End Sub

VBA_dev_Anne_Marie · 13 Septembre 2022

VBA_dev_Anne_Marie à dit:
Bonjour Staple1600,
Merci pour l'encadrement.
Je voulais refaire le nouvel encadrement à chaque fois que je crée mon tableau mais la commande Sheets("BDD").Cells.ClearContents n'enlève pas l'encadrement.
Auriez-vous des idées comment le supprimer automatiquement avant de le récréer (en fait, le nombre de lignes de mon tableau change à chaque fois que je récupère les données).

Merci pour votre aide !

Bonjour,

Finalement, j'ai écrit ce code et ça marche :
Sheets("TABLEAU").Cells.Borders.LineStyle = xlNone

Merci !

dysorthographie · 13 Septembre 2022

Bonjour,

VB:

Sheets("TABLEAU").Cells.Delete

VBA_dev_Anne_Marie · 13 Septembre 2022

Il

dysorthographie à dit:
Bonjour,

VB:

Sheets("TABLEAU").Cells.Delete

Merci ! Ça marche pour enlever les bordures ?

dysorthographie · 13 Septembre 2022

Ça enlève les bordures également

Staple1600 · 13 Septembre 2022

Bonsoir le fil

Autres syntaxes possibles

VB:

Sub test_A()
ActiveCell.Borders.Value = 0
End Sub
Sub test_B()
ActiveCell.ClearFormats
End Sub

NB: Mieux vaut la 1ère, si en plus des bordures, les cellules possèdent un format particulier.

dysorthographie · 13 Septembre 2022

Staple1600 à dit:
Bonsoir le fil

Autres syntaxes possibles

VB:

Sub test_A() ActiveCell.Borders.Value = 0 End Sub Sub test_B() ActiveCell.ClearFormats End Sub

NB: Mieux vaut la 1ère, si en plus des bordures, les cellules possèdent un format particulier.

En même temps il faut tout supprimer !

Staple1600 · 13 Septembre 2022

Re

@dysorthographie
Mon message avait un caractère informatif.
Ni plus, ni moins.

Si j'étais moi, personnellement, je me convaincrai de pas appliquer des bordures sur l'ensemble des cellules d'une feuille.
Et étant moi, depuis la mitan du siècle dernier, je sais qu'on peut au besoin dans les options d'Excel, faire en sorte que le quadrillage fasse office de bordure à l'impression de la feuille.

VBA_dev_Anne_Marie · 14 Septembre 2022

dysorthographie à dit:
Ça enlève les bordures également

Merci !

VBA_dev_Anne_Marie · 23 Septembre 2022

dysorthographie à dit:

J'attends tes question!

VB:

Enum d
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
End Enum
Sub transpose()
Dim Obj As Object, Nb As Object: Set Obj = CreateObject("ADODB.Recordset"): Set Nb = CreateObject("ADODB.Recordset")    'on creer la collection
Obj.Fields.Append "Name", adChar, 50
Obj.Open
Nb.Fields.Append "Name", adChar, 50
Nb.Fields.Append "NB", adInteger, 4
Nb.Open
Dim Lib As String, L As Integer
Worksheets("feuil2").UsedRange.ClearContents
With Worksheets("feuil1").Range("A1").CurrentRegion
    col = 0
    nom = .Cells(1, 1)
    For X = 1 To .Rows.Count
        If Not CBool(InStr(1, Lib, "©" & .Cells(X, 2) & "©")) Then
            col = col + 1
            Sheets("feuil2").Range("A1").Offset(, col) = .Cells(X, 2)
            Lib = Lib & "©" & .Cells(X, 2) & "©"
        End If
        Obj.AddNew                                              'on ajoute un enregistrement à la collection
        Nb.Filter = "Name='" & Replace(.Cells(X, "A"), "'", "''") & "'"
        If Nb.EOF Then Nb.AddNew
        Obj("Name") = .Cells(X, "A"): Nb("Name") = .Cells(X, "A")
        Nb("NB") = Nb("NB") + 1
        Obj.Update: Nb.Update
        Nb.Filter = ""
        Obj.MoveFirst: Nb.MoveFirst
        Nb.Sort = "NB Desc"
    Next
End With
Obj.Filter = "Name='" & Replace(Nb("Name"), "'", "''") & "'"
If Not Obj.EOF Then Sheets("feuil2").Range("A2").CopyFromRecordset Obj
End Sub

Bonjour,
J'aurais une question, s'il vous plaît : si dans "Name='" & Replace(.Cells(X, "A"), "'", "''") & "'"
je souhaite mettre des dates comme 02/04/2021, par exemple, comment je dois modifier la ligne Name='" & Replace(.Cells(X, "A"), "'", "''") & "'".
Nb.Fields.Append "Name", adChar, 50 devient-il Nb.Fields.Append "Name", adInteger, 20 ?
En fait, dans ma colonne A j'ai :

01/01/2021

05/02/2021

05/03/2021

02/04/2021

07/05/2021

Merci pour votre aide !

Microsoft 365 VBA: Réorganiser les données

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

Staple1600

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

Staple1600

XLDnaute Barbatruc

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

Discussions similaires