Microsoft 365 VBA: Réorganiser les données

VBA_dev_Anne_Marie

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


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) :
1659285960290.png


Merci pour votre aide !
 

dysorthographie

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

VBA_dev_Anne_Marie

XLDnaute Occasionnel
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
Merci, ça marche bien.
Pourriez-vous m'expliquer cette ligne : InStr(1, Lib, "©" & .Cells(x, 2) & "©") ?
En fait, je ne comprends pas les paramètres 1, Lib, "©" :)
 

dysorthographie

XLDnaute Accro
Merci, ça marche bien.
Pourriez-vous m'expliquer cette ligne : InStr(1, Lib, "©" & .Cells(x, 2) & "©") ?
En fait, je ne comprends pas les paramètres 1, Lib, "©" :)
bonjour,
Instr permet de de retourner la position du premier caractère d'une sous chêne dans une chêne!
VB:
MsgBox instr(1,"123","2") 'le 2 est le caractère N°2
si instr me retourne la position d'une sous chêne trouvé il ne fait pas le distinguo entre 2 et 123!
d'où l'utilisation de "©"

"©" est un caractère qui existe vraiment mais qui n'est pas accessible nativement au clavier donc instr pourra faire le distinguo entre "©123©" et "©2©"
l'idée étant de mémoriser les colonnes déjà traité Lib="©aab©©ckm©"
Code:
MsgBox instr(1,"©aab©©ckm©","©ckm©")
MsgBox instr(1,"©A©©AA©©AAA©©AAAA©","©AAA©")
 
Dernière édition:

VBA_dev_Anne_Marie

XLDnaute Occasionnel
bonjour,
Instr permet de de retourner la position du premier caractère d'une sous chêne dans une chêne!
VB:
MsgBox instr(1,"123","2") 'le 2 est le caractère N°2
si instr me retourne la position d'une sous chêne trouvé il ne fait pas le distinguo entre 2 et 123!
d'où l'utilisation de "©"

"©" est un caractère qui existe vraiment mais qui n'est pas accessible nativement au clavier donc instr pourra faire le distinguo entre "©123©" et "©2©"
l'idée étant de mémoriser les colonnes déjà traité Lib="©aab©©ckm©"
Code:
MsgBox instr(1,"©aab©©ckm©","©ckm©")
MsgBox instr(1,"©A©©AA©©AAA©©AAAA©","©AAA©")
Merci beaucoup ! Est-ce que vous savez comment faire un test pour ne garder que les observations majoritaires en verticale ? Je fais count(N1) et count(N2) mais je ne sais pas comment ne garder que les 4 lignes ?

Merci !
 

dysorthographie

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

VBA_dev_Anne_Marie

XLDnaute Occasionnel
En fait tu ne veux garder que les valeurs majoritaire ?
Count(N1)=4
Count(N2)=2
Count(N3)=5

Dans ce cas de figure tu ne garde que N3 et peut importe l'ordre d'apparition dans le tableau ?

Oui, je ne garde que des observations majoritaires, s'il y a une égalité je ne garde que la première par exemple :
1659512146772.png


Merci pour votre aide !
 

Pièces jointes

  • 1659511950101.png
    1659511950101.png
    8.6 KB · Affichages: 18
  • 1659512078567.png
    1659512078567.png
    9.2 KB · Affichages: 18

VBA_dev_Anne_Marie

XLDnaute Occasionnel
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
Merci beaucoup,

En fait, je ne comprends pas cette partie :
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


Je ne comprends pas aussi pourquoi on utilise les adInteger, adDouble, adDecimal, adChar

dans cette partie du code :

Obj.Fields.Append "Name", adChar, 50
Obj.Open
Nb.Fields.Append "Name", adChar, 50
Nb.Fields.Append "NB", adInteger, 4

Merci !
 

dysorthographie

XLDnaute Accro
Bonsoir,
d'habitude on utilise l'objet recordset pour récupérer le résultat d'une requête. tu l'as toi même utiliser pour pour des requêtes sous Oracle.
VB:
recordset.Open Source, ActiveConnection, CursorType, LockType, Options

maintenant tu as utilisé Adodb.recordset via un connexion Oracle!
il m'arrives de détourner l'objet recordset pour les méthode et les propriétés qu'il propose.
en effet il est possible de faire des des recherche méthode Find
Code:
rs.Find "ID = '" & messID & "'"
de faire de filtres
Code:
rs.Filter = "City = '" & strCity & "'"
le résulta de la recherche ainsi que du filtre ce vérifie toujours à l'aide de la propriétés Eof
Code:
if Rs.eof=false then trouvé else pas trouvé

pour utiliser Adodb.recodset comme un collection indépendante d'un base de données il fau charger en mémoire la structure de l'aobjet Adodb.recordset pour simuler une requête Sql!

pour ce faire je vais créer un objet adodb.recordset;
à ce niveau il faut noter qu'il est possible d'ajouter la référence Microsoft ActiveX Data Objects
et ainsi accéder aux constantes de la librairie comme adChar.

je vais créer un objet recordset en activant Microsoft ActiveX Data Objects dans les librairies du projet.

  1. j'ajoute un instance de recordset
    Code:
    Dim Rs As New ADODB.Recordset
  2. je défini la structure de mas requête
    Code:
    Rs.Fields.Append "Nom Du Champs", adChar, 50
    Rs.Fields.Append "NB", adInteger, 4
    avec leur type de valeur char, Integer, date, autres...
  3. une fois ma requête structurée, je peux l'ouvrir
    Code:
    Rs.Open
  4. maintenant je peux lui entrer des données
    Code:
    Rs.AddNew
    Rs("Nom Du Champs") = "toto"
    Rs("NB") = "1"
    Rs.Update

  5. maintenant je peu vérifier si toto existe dans mon recordset

    Code:
    Rs.Filter = "[Nom Du Champs]='toto'"
    If Rs.EOF Then MsgBox "n'existe pas" Else MsgBox "existe"
  6. maintenant il est possible de faire un trie sur le recordset ça fonction un peux comme l'instruction ORDER BY d'une requête SQL!
    Code:
    Rs.Sort = "[Nom Du Champs] ASC, NB DESC" 'ASCendet, DESCendent
  7. notes que l'énumérateur Enum d est la pour énumérer les constante Microsoft ActiveX Data Objects car dans le code que je t'es fourni je n'es pas activé les référence adodb et que j'utilises creatobject don il me faut reconstruire les constante ADO
    Code:
    Enum d
        adInteger = 3
        adDouble = 5
        adDate = 7
        adDecimal = 14
        adChar = 129
    End Enum
 
Dernière édition:

VBA_dev_Anne_Marie

XLDnaute Occasionnel
Bonsoir,
d'habitude on utilise l'objet recordset pour récupérer le résultat d'une requête. tu l'as toi même utiliser pour pour des requêtes sous Oracle.
VB:
recordset.Open Source, ActiveConnection, CursorType, LockType, Options

maintenant tu as utilisé Adodb.recordset via un connexion Oracle!
il m'arrives de détourner l'objet recordset pour les méthode et les propriétés qu'il propose.
en effet il est possible de faire des des recherche méthode Find
Code:
rs.Find "ID = '" & messID & "'"
de faire de filtres
Code:
rs.Filter = "City = '" & strCity & "'"
le résulta de la recherche ainsi que du filtre ce vérifie toujours à l'aide de la propriétés Eof
Code:
if Rs.eof=false then trouvé else pas trouvé

pour utiliser Adodb.recodset comme un collection indépendante d'un base de données il fau charger en mémoire la structure de l'aobjet Adodb.recordset pour simuler une requête Sql!

pour ce faire je vais créer un objet adodb.recordset;
à ce niveau il faut noter qu'il est possible d'ajouter la référence Microsoft ActiveX Data Objects
et ainsi accéder aux constantes de la librairie comme adChar.

je vais créer un objet recordset en activant Microsoft ActiveX Data Objects dans les librairies du projet.

  1. j'ajoute un instance de recordset
    Code:
    Dim Rs As New ADODB.Recordset
  2. je défini la structure de mas requête
    Code:
    Rs.Fields.Append "Nom Du Champs", adChar, 50
    Rs.Fields.Append "NB", adInteger, 4
    avec leur type de valeur char, Integer, date, autres...
  3. une fois ma requête structurée, je peux l'ouvrir
    Code:
    Rs.Open
  4. maintenant je peux lui entrer des données
    Code:
    Rs.AddNew
    Rs("Nom Du Champs") = "toto"
    Rs("NB") = "1"
    Rs.Update

  5. maintenant je peu vérifier si toto existe dans mon recordset

    Code:
    Rs.Filter = "[Nom Du Champs]='toto'"
    If Rs.EOF Then MsgBox "n'existe pas" Else MsgBox "existe"
  6. maintenant il est possible de faire un trie sur le recordset ça fonction un peux comme l'instruction ORDER BY d'une requête SQL!
    Code:
    Rs.Sort = "[Nom Du Champs] ASC, NB DESC" 'ASCendet, DESCendent
  7. notes que l'énumérateur Enum d est la pour énumérer les constante Microsoft ActiveX Data Objects car dans le code que je t'es fourni je n'es pas activé les référence adodb et que j'utilises creatobject don il me faut reconstruire les constante ADO
    Code:
    Enum d
        adInteger = 3
        adDouble = 5
        adDate = 7
        adDecimal = 14
        adChar = 129
    End Enum
Merci beaucoup ! C'est clair pour moi. Est-ce que vous savez comment ajouter le contour à ce tableau (selon le nombre de cellules récupérées) ? :)
 

dysorthographie

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

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 897
Membres
101 833
dernier inscrit
sandra25