Microsoft 365 Transposer les données date.

VBA_dev_Anne_Marie · 25 Septembre 2022

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 !

dysorthographie · 25 Septembre 2022

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...

dysorthographie · 25 Septembre 2022

Bonjour,
En [B1] on a ABB et en [D2] on a 1; j'imagine que ce lié à la ligne 1 du tableau initiale ?

Et le 2 de la ligne 2 du tableau initiale ?

Et pourquoi ckm 3 et pas 2?

VBA_dev_Anne_Marie · 25 Septembre 2022

dysorthographie à dit:
Bonjour,
En [B1] on a ABB et en [D2] on a 1; j'imagine que ce lié à la ligne 1 du tableau initiale ?

Et le 2 de la ligne 2 du tableau initiale ?

Et pourquoi ckm 3 et pas 2?

Merci, oui.
Ckm est à 3 parce que c’est la valeur de la première occurrence du 01/01/2021 pour ckm. 1 et 3 ce sont les premières occurrence.

dysorthographie · 25 Septembre 2022

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

VBA_dev_Anne_Marie · 3 Octobre 2022

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

Bonjour,
Merci, mais je reçois l'erreur suivante alors que j'ai bien feuil 1 :

VBA_dev_Anne_Marie · 3 Octobre 2022

VBA_dev_Anne_Marie à dit:
Bonjour,
Merci, mais je reçois l'erreur suivante alors que j'ai bien feuil 1 :
Regarde la pièce jointe 1151246

Je me demande comment on installe Microsoft.ACE.OLEDB.12.0

dysorthographie · 3 Octobre 2022

Bonjour,
Le message d'erreur ne te dis pas d'installer
Microsoft.ACE.OLEDB.12.0 mais s'il ne trouve pas la table [Feuil1$]

Comment s'appelle la feuille qui contient tes données ?

VBA_dev_Anne_Marie · 3 Octobre 2022

dysorthographie à dit:
Bonjour,
Le message d'erreur ne te dis pas d'installer
Microsoft.ACE.OLEDB.12.0 mais s'il ne trouve pas la table [Feuil1$]

Comment s'appelle la feuille qui contient tes données ?

Merci, c'est

VBA_dev_Anne_Marie · 3 Octobre 2022

dysorthographie à dit:
Bonjour,
Le message d'erreur ne te dis pas d'installer
Microsoft.ACE.OLEDB.12.0 mais s'il ne trouve pas la table [Feuil1$]

Comment s'appelle la feuille qui contient tes données ?

Voici mes données :

VBA_dev_Anne_Marie · 3 Octobre 2022

dysorthographie à dit:
Bonjour,
Le message d'erreur ne te dis pas d'installer
Microsoft.ACE.OLEDB.12.0 mais s'il ne trouve pas la table [Feuil1$]

Comment s'appelle la feuille qui contient tes données ?

L'erreur est ic

dysorthographie · 3 Octobre 2022

c'est bazar!

VB:

With .Execute("Select distinct [F4] from [Feuil1$] where [F4]  is not null")

VBA_dev_Anne_Marie · 3 Octobre 2022

dysorthographie à dit:
c'est bazar!

VB:

With .Execute("Select distinct [F4] from [Feuil1$] where [F4] is not null")

Merci, mais je reçois la même erreur :

dysorthographie · 3 Octobre 2022

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)

VBA_dev_Anne_Marie · 4 Octobre 2022

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)

Bonjour,
Merci, ça marche mieux, mais je ne sais pas pourquoi les dates 00/01/1900 apparaissent tout le temps.

dysorthographie · 4 Octobre 2022

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

Microsoft 365 Transposer les données date.

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

VBA_dev_Anne_Marie

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

Discussions similaires