Microsoft 365 Transposer les données date.

[VBA_dev_Anne_Marie]

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

Le code est :

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 !

 

[dysorthographie]

Bonjour,
Normal dans mon exemple le copyfromrecordset ce fait en A1 pas en F9

Sheets("CALCUL").Range("F9").Offset(,I).EntireColumn.NumberFormat

 

[VBA_dev_Anne_Marie]

Bonjour,
Normal dans mon exemple le copyfromrecordset ce fait en A1 pas en F9

Sheets("CALCUL").Range("F9").Offset(,I).EntireColumn.NumberFormat

Oui, je suis bien en F9 :


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

 

[dysorthographie]

Non il faut faire un décalage de I à partir de [F9]

If .Fields(I).Name Like "Value*" Then Sheets("CALCUL").Range("F9").Offset(,I).EntireColumn.NumberFormat

Idem pour les autres

 

[VBA_dev_Anne_Marie]

Non il faut faire un décalage de I à partir de [F9]

If .Fields(I).Name Like "Value*" Then Sheets("CALCUL").Range("F9").Offset(,I).EntireColumn.NumberFormat

Idem pour les autres

Merci !