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
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
             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
    For L = 1 To .Rows.Count
        OBJ.Filter = "[DATE]=#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#"
        If OBJ.EOF Then
            OBJ.AddNew
             For I = 0 To OBJ.Fields.Count - 1
                If Left(OBJ(I).Name, 5) = "Value" Then OBJ(I) = 0
             Next
        End If
'        End If
        OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "D").Text) = .Cells(L, "B")
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1
          If Trim(OBJ("Order" & .Cells(L, "D").Text)) = "" Then OBJ("Order" & .Cells(L, "D").Text) = .Cells(L, "C")
            OBJ.Update
        OBJ.MoveFirst
        OBJ(.Cells(L, "D").Text) = .Cells(L, "D").Text
        OBJ.Update
  
    Next
End With

OBJ.Filter = ""
If Not OBJ.EOF Then Sheets("feuil2").Range("A1").CopyFromRecordset OBJ
End Sub
 
Vote positif 0 Vote négatif
Solution
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
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
             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
    For L = 1 To .Rows.Count
        OBJ.Filter = "[DATE]=#" & Format(.Cells(L, "A"), "yyyy-mm-dd") & "#"
        If OBJ.EOF Then
            OBJ.AddNew
             For I = 0 To OBJ.Fields.Count - 1
                If Left(OBJ(I).Name, 5) = "Value" Then OBJ(I) = 0
             Next
        End If
'        End If
        OBJ("DATE") = .Cells(L, "A")
        OBJ("Value" & .Cells(L, "D").Text) = .Cells(L, "B")
        OBJ.Update
         OBJ.Filter = ""
            OBJ.Move 1
          If Trim(OBJ("Order" & .Cells(L, "D").Text)) = "" Then OBJ("Order" & .Cells(L, "D").Text) = .Cells(L, "C")
            OBJ.Update
        OBJ.MoveFirst
        OBJ(.Cells(L, "D").Text) = .Cells(L, "D").Text
        OBJ.Update
 
    Next
End With

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

Bonjour,
Merci, mais je reçois l'erreur suivante alors que j'ai bien feuil 1 :
1664810191809.png
 
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
test ça tu et regarde le nom des feuillesdans longlet 2
VB: 
ith CreateObject("ADODB.CONNECTION")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;"""
   Sheets("feuil2").Range("A1").CopyFromRecordset .OpenSchema(20)
 
Vote positif 0 Vote négatif
VBA_dev_Anne_Marie

VBA_dev_Anne_Marie

XLDnaute Occasionnel
dysorthographie à dit:
test ça tu et regarde le nom des feuillesdans longlet 2
VB: 
ith CreateObject("ADODB.CONNECTION")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;"""
   Sheets("feuil2").Range("A1").CopyFromRecordset .OpenSchema(20)
Cliquez pour agrandir...

Bonjour,
Merci, ça marche mieux, mais je ne sais pas pourquoi les dates 00/01/1900 apparaissent tout le temps.
1664856034277.png
 
Vote positif 0 Vote négatif

Discussions similaires

Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
378
Messan
Messan
D
  • Question
XL 2016 VBA format date
2
Réponses
17
Affichages
819
vgendron
vgendron
kalem
  • Question
Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.
Réponses
3
Affichages
580
ARMAEL
A
GADENSEB
  • Question
Microsoft 365 Macro .XLA découpage de fichiers à passer en X64
Réponses
8
Affichages
465
GADENSEB
GADENSEB
Ferbank
  • Question
XL 2019 modifier une macro
Réponses
2
Affichages
737
Ferbank
Ferbank
A
  • Question
Microsoft 365 VBA: importer dans un dossier avec un nom variable
Réponses
4
Affichages
742
A-F
A
D
  • Question
Microsoft 365 Modification d'un code VBA
Réponses
8
Affichages
649
Hasco
Hasco
M
  • Résolu(e)
XL 2013 Recherche selon critère et transposer des données avec récurrence
Réponses
3
Affichages
811
MarieChérie
M
M
  • Question
Microsoft 365 Copier les données d'une feuille à une autre
Réponses
6
Affichages
927
mimich_88
M
M
  • Question
Microsoft 365 VBA - Extraire tous les emails d'une cellule et les coller dans une autre feuille
Réponses
4
Affichages
563
mimich_88
M

Membres actuellement en ligne

4 membres et 52 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
312 177
Messages
2 085 972
Membres
103 073
dernier inscrit
MSCHOE16