Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Transposer les données date.

Créer une discussion

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

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


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 :



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 :



Le résultat :





Merci pour votre aide !
 
Solution
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 à dit:
Bonjour,
Oui c'est normal, ce lié à la ligne que je t'ai fait rajouter c'était pour connaître le nom des feuilles vue que le reste ne fonctionnait pas !

Supprimes la ligne avec openshema
Cliquez pour agrandir...

Bonjour,

Est-ce que vous pourriez commenter le code, s'il vous plaît ?
En fait, je voudrais le modifier car j'ai une colonne supplémentaire avec des données décimales (colonne C). J'ai remplacé le F4 par F5 mais je ne peux pas avancer puisque je n'arrive pas à trouver sur Internet les fonctions que vous avez utilisées. 🙁

J'aurais une autre question, si les données "valeur", on des décimales, elles ne s'affichent pas...

Par exemple, mais données en entrée sont :


Je voudrais avoir en output :



Je remarque, que, avec le code existant, le chiffre 343 131 et 559064 sont affichés sans décimales.
J'ai l'impression aussi que le code ne se lance pas si on a des données à vide, est-ce que je peux palier cela ?

Merci beaucoup pour votre aide !
 

Pièces jointes

  • 1669200891551.png
    13 KB · Affichages: 19
Vote positif 0 Vote négatif
Bonjour,
déjà on va aborder le sujet hors contexte, apprendre à manipuler l'objet RecordSet!

  1. l'objet RecordSet est souvent associé à une connexion ADODB!
    VB: 
    Set Rs=Cn.execute(SQL)
  2. on peut parcourir le RecordSet
    Code: 
    while not Rs.eof
    Rs.moveNext
wend
  3. on peut aller à la fin
    VB: 
    Rs.MoveLast
  4. aller au début
    Makefile: 
    Rs.moveFirst
  5. aller à un enregistrement précis!
    Code: 
     OBJ.Move 1
  6. filtre le RecordSet
    Code: 
    Rs.filter ="Champ=Valeur"
IF  Rs.eof then msgbox "Pas trouvé"
maintenant il es possible de créer un RecordSet en mémoire sans qu'il soit rattaché à un connexion adodb; comme je n'utilises pas les références ActiveX Data Object dans mon projets j'ai besoin de définir les constante ADO que je doit Utiliser!

DataTypeEnum (Access desktop database reference)

Office developer client VBA reference documentation
learn.microsoft.com

Code: 
Enum d
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
    adDate = 7
End Enum

je vais maintenant créer un Objet RecordSet et le manipuler!
  1. j'ajout un Objet RecorSet:
    Code: 
    Dim OBJ as Object
Set OBJ = CreateObject("ADODB.RECORDSET")
  2. je lui ajoute des champs
    Code: 
    OBJ.Fields.Append "Cham1", adInteger, 8
OBJ.Fields.Append "Cham2" ,adDouble, 18
OBJ.Fields.Append "Cham3",adDecimal, 18
OBJ.Fields.Append "Cham4",adChar, 500
OBJ.Fields.Append "Cham5",adDate, 10
  3. une fois les champs créé on peut ouvrir le RecordSet !
    Code: 
    OBJ.Open
  4. Maintenant que j'ai ouvert mon RecordSet je peut lui ajouter des données
    Code: 
    OBJ.AddNew
OBJ("Cham1")=255
OBJ("Cham2")=12.5
OBJ("Cham3")=123.345
OBJ("Cham4")="TOTO"
OBJ("Cham5")=Date
OBJ.Update
  5. bien évidement je peux vérifier si il existe un valeur avant d'ajouter!
    Code: 
    OBJ.filter="Cham4='TOTO'"
if Not OBJ.eof then
    OBJ.AddNew
    OBJ("Cham1")=255
    OBJ("Cham2")=12.5
    OBJ("Cham3")=123.345
    OBJ("Cham4")="TOTO"
    OBJ("Cham5")=Date
    OBJ.Update
end if
  6. je peux faire un tri de marnière ascendante
    VB: 
    OBJ.Sort = "Cham5 ASC
  7. de manière descente
    Code: 
    OBJ.Sort = "Cham5 DESC
  8. sur plusieurs champs
    Code: 
    OBJ.Sort = "Cham5 DESC,Cham2 ASC"
maintenant étudions ce qui nous intéresse!

nous voulons récupérer un tableau qui ressemble à ceci!



sir la ligne une nous avons le nom des champs de notre recordset
et dA2:A9 les enregistrement dans le recordset!
  1. dans un premier je j'ajoute un RecordeSet et je lui donne un champ Date!
    VB: 
    Worksheets("feuil2").UsedRange.ClearContentsDim I As Integer, L As Long, OBJ As Object
Set OBJ = CreateObject("ADODB.RECORDSET")
OBJ.Fields.Append "DATE", adDate, 8
  2. via une requête sur le fichier actif je récupère le nom des champs


    Code: 
    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 [F4] from [feuil1$] where [F4]  is not null") 'Recupération des valeur de la colonne D

        While Not .EOF 'parcoure le RecordSet

            'Acjout des valeur de la colonne D com Champ dnas le recorset

            OBJ.Fields.Append .Fields("F4"), adChar, 50

             OBJ.Fields.Append "Value" & .Fields("F4"), adInteger, 8

             OBJ.Fields.Append "Order" & .Fields("F4"), adInteger, 8

            .MoveNext

        Wend

    End With

    .Close

End With

  3. on ouvre le recordset et on ajoute 2 ligne vide qui correspondent à la ligne 1 et 2 du premier tableau!
    Code: 
    OBJ.OpenOBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update
  4. traitement du tableau de la feuil1
    Code: 
    With Sheets("feuil1").Range("A1").CurrentRegion 'on recupère la page de cellules qui ont des valeurs
    For L = 1 To .Rows.Count 'de la ligne 1 à la dernière
        OBJ.Filter = "[DATE]=#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#" 'je filtre mon Recordset sur AX 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
'      j'affect les valeur au RecordSet
        OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "D").Text) = .Cells(L, "B")
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1 'Enregistrement 1 soit ligne 2 du tableau sachant qu'un RecorSet commance à 0
           ' si le champ Order est Null ,OrderABB=Null par exeple
          If Trim(OBJ("Order" & .Cells(L, "D").Text)) = "" Then OBJ("Order" & .Cells(L, "D").Text) = .Cells(L, "C")
            OBJ.Update 'Mise ajour du recorset
        OBJ.MoveFirst 'retour au début Ligne 0
        OBJ(.Cells(L, "D").Text) = .Cells(L, "D").Text 'on affect la valeurde la cellule D au champ qui porte le même nom OBJ("ABB")="OBJ" par exeple
        OBJ.Update 'mis a jour du recordset

    Next
End With
  5. J'enlaive un filtre évetuel et je transvase le recordset dans la feuil2
    Code: 
    OBJ.Filter = ""If Not OBJ.EOF Then Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
Voila c'est fini!
Code: 
Option Explicit

Enum d 'enumérateur des constante ADO
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
    adDate = 7
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") '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 [F4] from [feuil1$] where [F4]  is not null") 'Recupération des valeur de la colonne D
        While Not .EOF 'parcoure le RecordSet
            'Acjout des valeur de la colonne D com Champ dnas le recorset
            OBJ.Fields.Append .Fields("F4"), adChar, 50
             OBJ.Fields.Append "Value" & .Fields("F4"), adInteger, 8
             OBJ.Fields.Append "Order" & .Fields("F4"), adInteger, 8
            .MoveNext
        Wend
    End With
    .Close
End With

OBJ.Open
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update

With Sheets("feuil1").Range("A1").CurrentRegion 'on recupère la page de cellules qui ont des valeurs
    For L = 1 To .Rows.Count 'de la ligne 1 à la dernière
        OBJ.Filter = "[DATE]=#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#" 'je filtre mon Recordset sur AX 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
'      j'affect les valeur au RecordSet
        OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "D").Text) = .Cells(L, "B")
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1 'Enregistrement 1 soit ligne 2 du tableau sachant qu'un RecorSet commance à 0
           ' si le champ Order est Null ,OrderABB=Null par exeple
          If Trim(OBJ("Order" & .Cells(L, "D").Text)) = "" Then OBJ("Order" & .Cells(L, "D").Text) = .Cells(L, "C")
            OBJ.Update 'Mise ajour du recorset
        OBJ.MoveFirst 'retour au début Ligne 0
        OBJ(.Cells(L, "D").Text) = .Cells(L, "D").Text 'on affect la valeurde la cellule D au champ qui porte le même nom OBJ("ABB")="OBJ" par exeple
        OBJ.Update 'mis a jour du recordset
 
    Next
End With

OBJ.Filter = ""
If Not OBJ.EOF Then Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End Sub
 

Pièces jointes

  • 1669209764133.png
    26.3 KB · Affichages: 18
Dernière édition:
Vote positif 0 Vote négatif
Merci beaucoup !

En fait, le filtre ne marche pas quand les dates sont à vide, dans ce cas de figure :




Je me demande si on peut "forcer" le type d'une variable dans ce cas ?
 
Vote positif 0 Vote négatif
Refais un imprime écran après avoir cliqué sur le bouton débogage de la fenêtre d'erreur !

le message dit que le type n'est pas bon!
si tu mets du texte dans integer ça plante!
VB: 
OBJ.Fields.Append "Cham1", adInteger, 8                   'integer
OBJ.Fields.Append "Cham2", adDouble, 18                   'double decimale
OBJ.Fields.Append "Cham3", adChar, 500                    'Texte
OBJ.Fields.Append "Cham4", adDate, 10                     'Date
 
Dernière édition:
Vote positif 0 Vote négatif
on peux filtre sur NULL mais toute les date à Null ????
VB: 
 OBJ.Filter = "[DATE]=" & IIf(Trim(.Cells(L, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#") 'je filtre mon Recordset sur AX qui es une date!

si la date est Null
Code: 
 If Trim(.Cells(L, "A")) <> "" Then OBJ("DATE") = .Cells(L, "A")
Code: 
Option Explicit

Private Enum d 'enumérateur des constante ADO
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
    adDate = 7
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") '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 [F4] from [feuil1$] where [F4]  is not null") 'Recupération des valeur de la colonne D
        While Not .EOF 'parcoure le RecordSet
            'Acjout des valeur de la colonne D com Champ dnas le recorset
            OBJ.Fields.Append .Fields("F4"), adChar, 50
             OBJ.Fields.Append "Value" & .Fields("F4"), adInteger, 8
             OBJ.Fields.Append "Order" & .Fields("F4"), adInteger, 8
            .MoveNext
        Wend
    End With
    .Close
End With

OBJ.Open
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update

With Sheets("feuil1").Range("A1").CurrentRegion 'on recupère la page 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, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#")
        OBJ.Filter = "[DATE]=" & IIf(Trim(.Cells(L, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#") 'je filtre mon Recordset sur AX 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
'      j'affect les valeur au RecordSet
       If Trim(.Cells(L, "A")) <> "" Then OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "D").Text) = .Cells(L, "B")
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1 'Enregistrement 1 soit ligne 2 du tableau sachant qu'un RecorSet commance à 0
           ' si le champ Order est Null ,OrderABB=Null par exeple
          If Trim(OBJ("Order" & .Cells(L, "D").Text)) = "" Then OBJ("Order" & .Cells(L, "D").Text) = .Cells(L, "C")
            OBJ.Update 'Mise ajour du recorset
        OBJ.movefirst 'retour au début Ligne 0
        OBJ(.Cells(L, "D").Text) = .Cells(L, "D").Text 'on affect la valeurde la cellule D au champ qui porte le même nom OBJ("ABB")="OBJ" par exeple
        OBJ.Update 'mis a jour du recordset
 
    Next
End With

OBJ.Filter = ""
If Not OBJ.EOF Then Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End Sub
 
Vote positif 0 Vote négatif
Merci beaucoup ! C'est plus clair maintenant.
Je suis en train de regarder comment modifier le code si jamais il y des colonnes supplémentaires.
J'aurais une question : dans l'output les décimals ne s'affichent pas et quand je mets : OBJ.Fields.Append "Value" & .Fields("F4"), adDecimal, 8 (en décimal), l'output affiche 343131 au lieu de 343131,43.
Est-ce qu'il y a un format d'affichage spécifique pour ce genre de données ?
 
Vote positif 0 Vote négatif
En fait, j'ai modifié le code pour afficher une colonne supplémentaire (le taux), mais elle s'affiche pas correctement, pourriez-vous regarder la coquille s'il vous plaît ?
VB: 
Option Explicit

Private Enum d 'enumérateur des constante ADO
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
    adDate = 7
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") '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"), adDecimal, 8
             OBJ.Fields.Append "Taux" & .Fields("F5"), adDecimal, 8
             OBJ.Fields.Append "Order" & .Fields("F5"), adInteger, 8
            
            .MoveNext
        Wend
    End With
    .Close
End With

OBJ.Open
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update

With Sheets("feuil1").Range("A1").CurrentRegion 'on recupère la page 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, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#")
        OBJ.Filter = "[DATE]=" & IIf(Trim(.Cells(L, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#") 'je filtre mon Recordset sur AX 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
'      j'affect les valeur au RecordSet
       If Trim(.Cells(L, "A")) <> "" Then OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "E").Text) = .Cells(L, "B")
        OBJ("Taux" & .Cells(L, "E").Text) = .Cells(L, "C")
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1 'Enregistrement 1 soit ligne 2 du tableau sachant qu'un RecorSet commance à 0
           ' si le champ Order est Null ,OrderABB=Null par exeple
          If Trim(OBJ("Order" & .Cells(L, "E").Text)) = "" Then OBJ("Order" & .Cells(L, "E").Text) = .Cells(L, "D")
            OBJ.Update 'Mise ajour du recorset
        OBJ.movefirst 'retour au début Ligne 0
        OBJ(.Cells(L, "E").Text) = .Cells(L, "E").Text 'on affect la valeurde la cellule D au champ qui porte le même nom OBJ("ABB")="OBJ" par exeple
        OBJ.Update 'mis a jour du recordset
 
    Next
End With

OBJ.Filter = ""
If Not OBJ.EOF Then Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End Sub
 
Vote positif 0 Vote négatif
Voici mes données en entrée :

Les décimales ne s'affiche pas pour le taux, je pense qu'il y a un problème de format.
Merci beaucoup pour votre aide !
 
Vote positif 0 Vote négatif
dysorthographie à dit:
Oui je n'ai pas réussi à utiliser le décimal utilises adDouble!

Le décimal fonction sur un nombre de caractères avant et après la virgule mais j'ai pas pigé la règle de nomage 😡
Cliquez pour agrandir...
Merci, ça marche bien et j'ai réussi à modifier le code !
Qu'est-ce que vous en pensez :

VB: 
Option Explicit

Private Enum d 'enumérateur des constante ADO
    adInteger = 3
    adDouble = 5
    adDecimal = 14
    adChar = 129
    adDate = 7
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") '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
            
            .MoveNext
        Wend
    End With
    .Close
End With

OBJ.Open
OBJ.AddNew: OBJ.Update
OBJ.AddNew: OBJ.Update

With Sheets("feuil1").Range("A1").CurrentRegion 'on recupère la page 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, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#")
        OBJ.Filter = "[DATE]=" & IIf(Trim(.Cells(L, "A")) = "", "Null", "#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#") 'je filtre mon Recordset sur AX 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
'      j'affect les valeur au RecordSet
       If Trim(.Cells(L, "A")) <> "" Then OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "E").Text) = .Cells(L, "B")
      
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1 'Enregistrement 1 soit ligne 2 du tableau sachant qu'un RecorSet commance à 0
           ' si le champ Order est Null ,OrderABB=Null par exeple
          If Trim(OBJ("Order" & .Cells(L, "E").Text)) = "" Then OBJ("Order" & .Cells(L, "E").Text) = .Cells(L, "D")
          If Trim(OBJ("Taux" & .Cells(L, "E").Text)) = "" Then OBJ("Taux" & .Cells(L, "E").Text) = .Cells(L, "C")
            OBJ.Update 'Mise ajour du recorset
        OBJ.movefirst 'retour au début Ligne 0
        OBJ(.Cells(L, "E").Text) = .Cells(L, "E").Text 'on affect la valeurde la cellule D au champ qui porte le même nom OBJ("ABB")="OBJ" par exeple
        OBJ.Update 'mis a jour du recordset
 
    Next
End With

OBJ.Filter = ""
If Not OBJ.EOF Then Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End Sub

Le résultat c'est :



Si vous savez comment supprimer les 0 qui traînent à la fin je suis preneuse !

Merci !
 
Vote positif 0 Vote négatif
bonjour,
tu commence à métriser le sujet!
je suis sur mon téléphone portable je ne peux pas tester mais ça devrait ressembler à ça!
VB: 
Dim Condition As Boolean, F As Integer
If Not OBJ.EOF Then
For I = OBJ.RecordCount - 1 To 0 Step -1
   OBJ.Move I
    Condition = False
   For F = 0 To OBJ.fields.Count - 1
        Condition = IIf(Trim(OBJ.fields(F)) = "" Or Trim(OBJ.fields(F)) = "0", False, True)
        If Condition Then Exit For
   Next
   If Not Condition Then OBJ.Delete
    OBJ.movefirst
Next
    OBJ.movefirst
    Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End If
 
Dernière édition:
Vote positif 0 Vote négatif
Merci,

C'est le code pour supprimer les 0 ?
Je viens de me rendre compte que je peux ajouter les colonnes après la date, mais je n'arrive pas à ajouter les colonnes avant le champs "date", où il faudrait modifier le code, s'il vous plait ?

Merci !
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
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

A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
347
patricktoulon
  • Question Question
XL 2016 XLS - Comment déterminer les zones présentent au niveau d'une cellule ?
Réponses
2
Affichages
199
Lu76Fer
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
898
Messan
EXCEL :: Les Tableaux Structurés :: Une classe VBA - V1.05 - Evolutions majeures exports CSV, XML, XML UTF-8, JSON, HTML, PDF, JPG, JPEG, BMP, EXCEL
Réponses
10
Affichages
415
oguruma
M
  • Résolu(e)
XL 2013 Recherche selon critère et transposer des données avec récurrence
Réponses
3
Affichages
1 K
MarieChérie
M
M
  • Question Question
Microsoft 365 Copier les données d'une feuille à une autre
Réponses
6
Affichages
1 K
mimich_88
M
S
  • Résolu(e)
XL 2016 Fusionner les doublons de date
Réponses
6
Affichages
1 K
scrib
S
J
  • Résolu(e)
XL 2016 Transposer certains groupe de colonnes en ligne VBA
Réponses
9
Affichages
3 K
joaoratao
J
  • Question Question
XL 2010 Macro Synthèse Excel Vba
Réponses
0
Affichages
1 K
Mirguy23
C
  • Question Question
Bug Erreur !!!Type défini par l'utilisateur non défini
2
Réponses
18
Affichages
6 K
ChTi160
T
  • Question Question
Trier les informations d'une liste déroulante
Réponses
3
Affichages
2 K
Toubabou
T
D
  • Question Question
[VBA] Problème sur une plage de valeurs variables d'un graphique
Réponses
2
Affichages
2 K
Djihell
D
A
  • Question Question
Mon userform ne renvoie pas les info
Réponses
14
Affichages
2 K
aziz
A
D
  • Question Question
Soucis Code VBA copie colle sous condition
Réponses
0
Affichages
674
d.deneys
D
N
  • Question Question
Booster une macro
Réponses
5
Affichages
3 K
Staple1600
B
  • Question Question
Problèmes de macro liés à l'extraction et à l'envoi d'un fichier
Réponses
0
Affichages
1 K
benadry
B
B
  • Question Question
Problème avec une macro Excel pour envoyer des fichiers par mail
Réponses
2
Affichages
1 K
benadry
B
M
  • Question Question
Combinaison ARRAY
Réponses
0
Affichages
2 K
MARGAR
M
  • Question Question
Vider un module sans le supprimer, puis recréer du VBA dans ce module-là précisément
Réponses
5
Affichages
3 K
EtienneChouard
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…