Microsoft 365 Transposer les données date.

VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
Bonjour,
Je souhaite transposer le tableau (en ligne je ne garde que les observation présentent en majorité) :
1664100560680.png


Le code est :
VB: 
Option Explicit

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, nom As String, X As Integer, col As Integer
Worksheets("feuil2").UsedRange.ClearContents
With Worksheets("feuil1").Range("A1").CurrentRegion
    nom = .Cells(1, 1)
    col = 0
    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

Malheureusement le résultat que j'obtient s'affiche comme :

1664100645883.png


Je me demande comment modifier Nb.Fields.Append "Name", adChar, 50 pour pouvoir récupérer la variable au format date ?

J'aurais aussi une autre question: comment modifier Recordset dans le code précédent pour ajouter la colonne (B) et la première observation de la colonne C pour chaque élément de D :

Tableau initial :

1664100880894.png


Le résultat :
1664100936903.png





Merci pour votre aide !
 
Solution
dysorthographie
VB: 
Option Explicit

Enum d
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
    adDate = 7
   ' adDBDate = 133
End Enum
Sub NewTranspose()
Worksheets("feuil2").UsedRange.ClearContents
Dim I As Integer, L As Long, OBJ As Object
Set OBJ = CreateObject("ADODB.RECORDSET")
OBJ.Fields.Append "DATE", adDate, 8

With CreateObject("ADODB.CONNECTION")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;"""
    With .Execute("Select distinct [F4] from [feuil1$] where [F4]  is not null")
        While Not .EOF
            OBJ.Fields.Append .Fields("F4"), adChar, 50
             OBJ.Fields.Append "Value" & .Fields("F4"), adInteger, 8...
Trier par date Trier par votes
dysorthographie

dysorthographie

XLDnaute Accro
le champ date doit être unique, là tu tentais de le recréer à chaque movenext
VB: 
Set OBJ = CreateObject("ADODB.RECORDSET")
Dim Fd As Boolean

With CreateObject("ADODB.CONNECTION") 'Objet de Connection ADODB
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;""" 'Connexion sur le fichier Actif
    With .Execute("Select distinct [F5] from [feuil1$] where [F5]  is not null") 'Recupération des valeur de la colonne E
        While Not .EOF 'parcoure le RecordSet
            'Acjout des valeur de la colonne D com Champ dnas le recorset
             OBJ.Fields.Append .Fields("F5"), adChar, 50
             OBJ.Fields.Append "Value" & .Fields("F5"), adDouble, 5
             OBJ.Fields.Append "Order" & .Fields("F5"), adDouble, 5
             OBJ.Fields.Append "Taux" & .Fields("F5"), adDouble, 5
             If Not Fd Then OBJ.Fields.Append "DATE", adDate, 8: Fd = True
         
            .MoveNext
        Wend
    End With
    .Close
End With
 
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
le champ date doit être unique, là tu tentais de le recréer à chaque movenext
VB: 
Set OBJ = CreateObject("ADODB.RECORDSET")
Dim Fd As Boolean

With CreateObject("ADODB.CONNECTION") 'Objet de Connection ADODB
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;""" 'Connexion sur le fichier Actif
    With .Execute("Select distinct [F5] from [feuil1$] where [F5]  is not null") 'Recupération des valeur de la colonne E
        While Not .EOF 'parcoure le RecordSet
            'Acjout des valeur de la colonne D com Champ dnas le recorset
             OBJ.Fields.Append .Fields("F5"), adChar, 50
             OBJ.Fields.Append "Value" & .Fields("F5"), adDouble, 5
             OBJ.Fields.Append "Order" & .Fields("F5"), adDouble, 5
             OBJ.Fields.Append "Taux" & .Fields("F5"), adDouble, 5
             If Not Fd Then OBJ.Fields.Append "DATE", adDate, 8: Fd = True
        
            .MoveNext
        Wend
    End With
    .Close
End With
Cliquez pour agrandir...
Oui, car j’ai ajouté 2 colonnes en plus avec d’autres dates, je voulais les placer au début.
 
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
Bonjour,
déjà tu as bien compris que F dans la requête représente un Field! [F1] colonne A {F2] Colonne B [FX] etc.

select distinct [F2] signifie colonne B sans doublons!
sachant que OBJ.Fields.Append ne peux pas avoir deux champ du même non regarde l'image lié à ton code!

la date en jaune correspond à la deuxième occurrences du movenext!

1669398385033.png
 
Dernière édition:
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
Bonjour,
déjà tu as bien compris que F dans la requête représente un Field! [F1] colonne A {F2] Colonne B [FX] etc.

select distinct [F2] signifie colonne B sans doublons!
sachant que OBJ.Fields.Append ne peux pas avoir deux champ du même non regarde l'image lié à ton code!

la date en jaune correspond à la deuxième occurrences du movenext!

Regarde la pièce jointe 1156419
Cliquez pour agrandir...
Merci !
J'aurais deux petites questions, s'il vous plaît :
Je voulais insérer deux lignes vides en plus entre la ligne 1 et 3 pour avoir plus d'espace, je n'arrive pas à placer

OBJ.Open
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update dans le code.

1669418378721.png


Est-il possible assigner des formats monétaire à Value et le format Pourcent à Order dans le code ?

Merci !
 
Dernière édition:
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
VB: 
   Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End If
With OBJ
    For I = 0 To .fields.Count - 1
        If .fields(I).Name Like "Value*" Then Sheets("feuil2").Columns(I + 1).NumberFormat = "#0.00 €"
        If .fields(I).Name Like "Order*" Then Sheets("feuil2").Columns(I + 1).NumberFormat = "#0.00 %"
    Next
End With
End Sub
 
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
VB: 
   Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End If
With OBJ
    For I = 0 To .fields.Count - 1
        If .fields(I).Name Like "Value*" Then Sheets("feuil2").Columns(I + 1).NumberFormat = "#0.00 €"
        If .fields(I).Name Like "Order*" Then Sheets("feuil2").Columns(I + 1).NumberFormat = "#0.00 %"
    Next
End With
End Sub
Cliquez pour agrandir...
Merci !

En fait, j'ai modifié un peu le code, et j'ai fait une régression :( le code ajoute les colonnes inutiles (surlignées en jaune). Pourriez-vous regarder, s'il vous plaît, car je ne trouve pas d'erreur :
1669553852926.png


VB: 
'TRANSPOSE


Sub NewTranspose()
Worksheets("CALCUL").UsedRange.ClearContents
Dim I As Integer, L As Long, OBJ As Object
Set OBJ = CreateObject("ADODB.RECORDSET")
OBJ.Fields.Append "DATE", adDate, 8

'1 ) On récupère le nom des champs via une requête sur le fichier actif

With CreateObject("ADODB.CONNECTION") 'Objet de Connection ADODB
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;""" 'Connexion sur le fichier Actif
    With .Execute("Select distinct [F2] from [DONNEES_EA$] where [F2]  is not null") 'Recupération des valeur de la colonne B (code support)
        While Not .EOF 'parcoure le RecordSet
            'Acjout des valeur de la colonne B com Champ dnas le recorset
         
             OBJ.Fields.Append .Fields("F2"), adChar, 50
             OBJ.Fields.Append "Value" & .Fields("F2"), adDouble, 5
             OBJ.Fields.Append "Order" & .Fields("F2"), adDouble, 5
             OBJ.Fields.Append "Taux" & .Fields("F2"), adDouble, 5
           
            .MoveNext
        Wend
    End With
    .Close
End With

'2 ) Fin création des champs

'3 ) on ouvre le recordset (OBJ.Open) et on ajoute 5 lignes vides
OBJ.Open
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update


'4) traitement du tableau de la feuil1 CALCUL

With Sheets("DONNEES_EA").Range("A1").CurrentRegion 'on recupère la plage de cellules qui ont des valeurs
    For L = 1 To .Rows.Count 'de la ligne 1 à la dernière
    Debug.Print IIf(Trim(.Cells(L, "F")) = "", "Null", "#" & Format(.Cells(L, "F"), "yyyy-mm-dd") & "#")
        OBJ.Filter = "[DATE]=" & IIf(Trim(.Cells(L, "F")) = "", "Null", "#" & Format(.Cells(L, "F"), "yyyy-mm-dd") & "#") 'je filtre mon Recordset sur F qui es une date
        If OBJ.EOF Then 'Si la date nexiste pas
            OBJ.AddNew 'je l'ajoute au recorset
             For I = 0 To OBJ.Fields.Count - 1
                If Left(OBJ(I).Name, 5) = "Value" Then OBJ(I) = 0 'je mets tous les champs Value à 0
             Next
        End If

 
  '4.2)      j'affect les valeur au RecordSet
 
       If Trim(.Cells(L, "F")) <> "" Then OBJ("DATE") = .Cells(L, "F")
       OBJ("Value" & .Cells(L, "B").Text) = .Cells(L, "G")
        OBJ.Update 'mis a jour du recordset
         OBJ.Filter = ""
       
       
            OBJ.Move 3 'Enregistrement 2 soit ligne 4 du tableau sachant qu'un RecordSet commance à 0
           ' si le champ Order est Null ,OrderABB=Null par exeple
         
          If Trim(OBJ("Order" & .Cells(L, "B").Text)) = "" Then OBJ("Order" & .Cells(L, "B").Text) = .Cells(L, "H")
          If Trim(OBJ("Taux" & .Cells(L, "B").Text)) = "" Then OBJ("Taux" & .Cells(L, "B").Text) = .Cells(L, "C")
            OBJ.Update 'Mise ajour du recorset
           
        OBJ.MoveFirst 'retour au début Ligne 1, soit ligne 3
        OBJ(.Cells(L, "B").Text) = "CD_SUPPORT" & Space(3) & .Cells(L, "B").Text 'on affect la valeurde la cellule B au champ qui porte le même nom OBJ("ABB")="OBJ" par exeple
        OBJ.Update 'mis a jour du recordset

       
 
    Next
End With

  '4.3)   on copie les données
OBJ.Filter = ""
If Not OBJ.EOF Then Sheets("CALCUL").Range("F9").CopyFromRecordset OBJ
'
'With OBJ
'    For I = 0 To .Fields.Count - 1
'    If .Fields(I).Name Like "Value*" Then Sheets("CALCUL").Columns(I + 1).NumberFormat = "#0.00 €"
'    If .Fields(I).Name Like "Order*" Then Sheets("CALCUL").Columns(I + 1).NumberFormat = "#0.00 €"
'    If .Fields(I).Name Like "Taux*" Then Sheets("CALCUL").Columns(I + 1).NumberFormat = "#0.00 %"
'   Next
'End With
End Sub

Il me semble que l'anomalie apparaît pour les premières colonnes après la date.
Merci beaucoup !
 

Pièces jointes

  • 1669553015819.png
    1669553015819.png
    22.6 KB · Affichages: 16
  • 1669553833347.png
    1669553833347.png
    23.3 KB · Affichages: 14
Dernière édition:
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
Bonjour,
je vais regarder mais en attendant tu peux modifier ton code comme suis ça va t'aider à voir ou est l'erreur!
VB: 
OBJ.Filter = ""
For i = 0 To OBJ.Fields.Count - 1
       Sheets("CALCUL").Range("F8").Offset(, i) = "[" & OBJ(i).Name & "]"
    Next
If Not OBJ.EOF Then Sheets("CALCUL").Range("F9").CopyFromRecordset OBJ
Cliquez pour agrandir...
En fait, à chaque lancement, il ajoute des colonnes en plus, je regarde.
 
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
VB: 
   Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End If
With OBJ
    For I = 0 To .fields.Count - 1
        If .fields(I).Name Like "Value*" Then Sheets("feuil2").Columns(I + 1).NumberFormat = "#0.00 €"
        If .fields(I).Name Like "Order*" Then Sheets("feuil2").Columns(I + 1).NumberFormat = "#0.00 %"
    Next
End With
End Sub
Cliquez pour agrandir...
Ce code n'assigne pas le format, existe-t-il une autre méthode, s'il vous plaît ?
 
Vote positif 0 Vote négatif

Discussions similaires

Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
847
Nicolas JACQUIN
Nicolas JACQUIN
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
628
Messan
Messan
D
  • Question
XL 2016 VBA format date
2
Réponses
17
Affichages
1 K
vgendron
vgendron
kalem
  • Question
Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.
Réponses
3
Affichages
759
ARMAEL
A
GADENSEB
  • Question
Microsoft 365 Macro .XLA découpage de fichiers à passer en X64
Réponses
8
Affichages
631
GADENSEB
GADENSEB
Ferbank
  • Question
XL 2019 modifier une macro
Réponses
2
Affichages
925
Ferbank
Ferbank
A
  • Question
Microsoft 365 VBA: importer dans un dossier avec un nom variable
Réponses
4
Affichages
863
A-F
A
D
  • Question
Microsoft 365 Modification d'un code VBA
Réponses
8
Affichages
832
Hasco
Hasco
M
  • Résolu(e)
XL 2013 Recherche selon critère et transposer des données avec récurrence
Réponses
3
Affichages
966
MarieChérie
M
M
  • Question
Microsoft 365 Copier les données d'une feuille à une autre
Réponses
6
Affichages
1 K
mimich_88
M

Membres actuellement en ligne

4 membres et 67 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 485
Messages
2 110 101
Membres
110 663
dernier inscrit
ToussaintBug