Microsoft 365 VBA: Réorganiser les données

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
VBA_dev_Anne_Marie

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 !
 
Trier par date Trier par votes
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
 
Vote positif 0 Vote négatif
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
Cliquez pour agrandir...
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, "©" 🙂
 
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie à dit:
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, "©" 🙂
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
dysorthographie à dit:
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©")
Cliquez pour agrandir...
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 !
 
Vote positif 0 Vote négatif
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:
Vote positif 0 Vote négatif
dysorthographie à dit:
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 ?
Cliquez pour agrandir...

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: 23
  • 1659512078567.png
    1659512078567.png
    9.2 KB · Affichages: 24
Vote positif 0 Vote négatif
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
Cliquez pour agrandir...
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 !
 
Vote positif 0 Vote négatif
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:
Vote positif 0 Vote négatif
dysorthographie à dit:
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
Cliquez pour agrandir...
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) ? 🙂
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Chubby
  • Résolu(e)
Microsoft 365 Modification esthétique tab
2
Réponses
18
Affichages
177
Chubby
Chubby
S
  • Question Question
XL 2021 Automatisation et synthèse données
Réponses
1
Affichages
104
Dand87
D
B
  • Question Question
XL 2016 Comment réorganiser un tableau via macro vba
Réponses
2
Affichages
362
bnolwalid
B
A
  • Question Question
Déplacer données en vba
Réponses
3
Affichages
469
akm
A
R
  • Résolu(e)
XL 2021 Controle de la qualité de l’eau
Réponses
12
Affichages
527
Roro40
R
M
  • Résolu(e)
XL 2021 VBA Ajouter ligne tableau + autres cellules hors tableau
Réponses
3
Affichages
166
sylvanu
sylvanu
X
  • Question Question
XL 2021 Transformation de données sur une ligne en plusieurs lignes
Réponses
9
Affichages
406
xavieralvaro
X
A
  • Question Question
Microsoft 365 VBA et "Slicer" dans un TCD (source modèle de données)
Réponses
2
Affichages
132
Amilo
A
B
  • Résolu(e)
Microsoft 365 modifier des lignes
Réponses
5
Affichages
112
Hecatonchire
H
P
  • Question Question
XL 2016 VBA Appliquer un filtre sur mes données importées
Réponses
4
Affichages
520
sousou
sousou
fvr1
  • Résolu(e)
XL 2021 Récupération de données sur une seconde feuille
Réponses
8
Affichages
385
fvr1
fvr1
P
  • Résolu(e)
XL 2021 Requête API - VBA Excel - Parse JSON
Réponses
2
Affichages
483
picc
P
P
  • Question Question
XL 2019 Macro VBA appliquer un filtre lors d'une importation de données
Réponses
1
Affichages
389
fanch55
fanch55
G
  • Question Question
Microsoft 365 Formule calcul heures de travail
Réponses
8
Affichages
286
job75
job75
A
  • Question Question
XL 2010 Problème ou alternative à SOMPRODUCT en VBA
Réponses
14
Affichages
556
bruno lemaire
B
B
  • Résolu(e)
Microsoft 365 Recherche de plusieurs critères dans une cellule
2
Réponses
19
Affichages
352
Bambi35
B
W
  • Question Question
XL 2016 Problème d'écriture avec Range(Cells(x,y), Cells(x+n,y))
Réponses
13
Affichages
211
Webperegrino
W
N
  • Question Question
Microsoft 365 Créer une fenêtre de vente qui alimentera un cumul dans un tableau
Réponses
2
Affichages
293
job75
job75
A
  • Question Question
Microsoft 365 Vérifier si un texte existe dans une cellule contenant une liste
Réponses
9
Affichages
347
arzac
A
vgendron
  • Question Question
XL 2021 Références "Relatives" Graphique
Réponses
2
Affichages
203
vgendron
vgendron
Retour