Générer Tableau avec VBA

Le 12/10/2015 à 14:28

Bonjour,

je voudrais générer un tableau (Tableau 2) à partir de mon premier tableau (Tableau 1) avec vba.

C'est un manip que je faisais toujours avec les TCD et c'était simple aussi.

A titre d'exemple j'ai joint un fichier. Si c'est possible je peux l'adapter à mes besoins.

Merci d'avance.

17tableau.zip (6.39 Ko)
Le 12/10/2015 à 14:39

Bonjour

pourquoi ne pas garder un TCD ??? c'est tellement plus simple...

on peu éventuellement faire par macro une mise à jour si des nouvelles données sont enregistrée par exemple ....

pourrais tu developper pourquoi tu veux faire cela par macro ?

fred

12tableau.zip (4.92 Ko)
Le 12/10/2015 à 16:18

Bonjour,

Une proposition TCD en VBA.

Cdlt.

17tableau.xlsm (22.59 Ko)
Option Explicit
Option Private Module

Public Sub CreatePT()
Dim wb As Workbook
Dim wsData As Worksheet
Dim lo As ListObject
Dim PTCache As PivotCache
Dim PT As PivotTable

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("Données")
    Set lo = wsData.ListObjects(1)

    On Error Resume Next
    wb.Worksheets("TCD").Delete
    On Error GoTo 0

    Set PTCache = wb.PivotCaches.Create(xlDatabase, lo.Range, 4)

    wb.Worksheets.Add
    ActiveSheet.Name = "TCD"

    Set PT = PTCache.CreatePivotTable(Cells(1), "TCD_1", , 4)

    With PT
        .ManualUpdate = True
        .AddFields RowFields:="Voiture", ColumnFields:="Energie"
        With .PivotFields("Energie")
            .Orientation = xlDataField
            .Function = xlCount
            .NumberFormat = "#,##0"
            .Caption = "NB Energie"
        End With
        .RowAxisLayout xlTabularRow
        .ManualUpdate = False
    End With

    ActiveWindow.DisplayGridlines = False
    wb.ShowPivotTableFieldList = False
    Application.DisplayAlerts = True

    Set PT = Nothing
    Set PTCache = Nothing
    Set lo = Nothing
    Set wsData = Nothing
    Set wb = Nothing

End Sub
Le 13/10/2015 à 15:04

Bonjour,

Merci pour vos solution surtout le macro avec le TCD ça peut aider mais dans mon cas cela ne va pas m'arranger pour la suite.

Du coup j'ai trouvé un macro qui me permet de recopier chaque modèle de voiture à chaque fois que je change de feuille.

Sub Recopie()
Dim J As Long
Dim Mondico As Object

  Application.ScreenUpdating = False
  If Range("B12") <> "" Then
    Range("B12:B" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
  End If
  Set Mondico = CreateObject("Scripting.dictionary")
  With Sheets("Feuil1")
    For J = 10 To .Range("B" & Rows.Count).End(xlUp).Row
      Mondico(.Range("B" & J).Value) = ""
      Next J
  End With
  If Mondico.Count > 0 Then
    Range("B10").Resize(Mondico.Count, 1) = Application.Transpose(Mondico.keys)
  End If

End Sub

Ce qui me reste à présent c'est de trouver un mois de compter pour chaque modèle de voiture ceux qui sont "essence" et ceux qui sont "diesel" dans la colonne "C".

Plus clairement, je veux comparer deux plages de cellule et compter les cellules identique.

Par avance merci.

16tableau.zip (10.75 Ko)
Le 13/10/2015 à 21:23

Bonsoir khech, le forum

Vois ceci :

Option Explicit

Sub Compter()
Dim a, b(), i As Long, n As Long, t As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    a = Sheets("Feuil1").Range("b9").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    n = 1: t = 1
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                n = n + 1: dico(a(i, 1)) = n
                b(n, 1) = a(i, 1)
            End If
            If Not .exists(a(i, 2)) Then
                t = t + 1: .Item(a(i, 2)) = t
                If t > UBound(a, 2) Then
                    ReDim Preserve b(1 To UBound(a, 1), _
                                     1 To UBound(b, 2) + 1)
                End If
                b(1, t) = a(i, 2)
            End If
            b(dico(a(i, 1)), .Item(a(i, 2))) = b(dico(a(i, 1)), .Item(a(i, 2))) + 1
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets.Add().Cells(1).Resize(n, t)
        .Value = b
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        With .Rows(1)
            .BorderAround Weight:=xlThin
            With .Offset(, 1).Resize(, .Columns.Count - 1)
                .Interior.ColorIndex = 36
            End With
        End With
        With .Columns(1)
            With .Offset(1).Resize(.Rows.Count - 1)
                .Interior.ColorIndex = 38
            End With
        End With
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 13/10/2015 à 21:45

Bonjour Klin89,

tout d'abord merci pour votre réponse, je l’attendais avec impatience pour avoir de quoi démarrer.

Le résultat y est mais à chaque fois qu'on exécute le macro, il crée une nouvelle feuille.

Est il possible de mettre de créer la feuille une seule fois ou bien mieux de l'affecter directement dans le tableau préétablie dans la feuille2 .

Merci par avance.

Le 14/10/2015 à 11:49

Bonjour,

La proposition est identique à la précédente, mais le TCD est copié en cellule B9 et supprimé.

A étudier.

Cdlt.

14tableau-v1.xlsm (17.99 Ko)
Option Explicit
'Option Private Module

Public Sub CreateTable()
Dim wb As Workbook
Dim wsData As Worksheet
Dim rngData As Range
Dim PTCache As PivotCache
Dim PT As PivotTable

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("Données")
    Set rngData = wsData.Cells(9, 2).CurrentRegion

    On Error Resume Next
    wb.Worksheets("TCD").Delete
    On Error GoTo 0

    Set PTCache = wb.PivotCaches.Create(xlDatabase, rngData, 4)    wb.Worksheets.Add
    ActiveSheet.Name = "TCD"

    Set PT = PTCache.CreatePivotTable(Cells(8), "TCD_1", , 4)

    With PT
        .ManualUpdate = True
        .AddFields RowFields:="Voiture", ColumnFields:="Energie"
        With .PivotFields("Energie")
            .Orientation = xlDataField
            .Function = xlCount
            .NumberFormat = "#,##0"
            .Caption = "NB Energie"
        End With
        .RowAxisLayout xlTabularRow
       .ColumnGrand = False
        .RowGrand = False
        .TableStyle2 = ""       
        .ManualUpdate = False
    End With

   [B7] = "Tableau 2"
    PT.TableRange1.Offset(1, 0).Copy Destination:=Cells(9, 2)
    PT.TableRange2.Clear
    [B9].CurrentRegion.Borders.Weight = xlThin
    [B9:D9].Interior.ColorIndex = 15
    Application.DisplayAlerts = True

    Set PT = Nothing
    Set PTCache = Nothing
    Set rngData = Nothing
    Set wsData = Nothing
    Set wb = Nothing

End Sub
Le 14/10/2015 à 13:18

Re,

Option Explicit

Sub Compter()
Dim a, b(), i As Long, n As Long, t As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    a = Sheets("Feuil1").Range("b9").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    n = 1: t = 1
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                n = n + 1: dico(a(i, 1)) = n
                b(n, 1) = a(i, 1)
            End If
            If Not .exists(a(i, 2)) Then
                t = t + 1: .Item(a(i, 2)) = t
                If t > UBound(a, 2) Then
                    ReDim Preserve b(1 To UBound(a, 1), _
                                     1 To UBound(b, 2) + 1)
                End If
                b(1, t) = a(i, 2)
            End If
            b(dico(a(i, 1)), .Item(a(i, 2))) = b(dico(a(i, 1)), .Item(a(i, 2))) + 1
        Next
    End With
    'Restitution en Feuil2
    Application.ScreenUpdating = False
    With Sheets("Feuil2")
        .Cells.Clear
        With .Cells(1).Resize(n, UBound(b, 2))
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .Interior.ColorIndex = 36
                End With
            End With
            With .Columns(1)
                With .Offset(1).Resize(.Rows.Count - 1)
                    .Interior.ColorIndex = 38
                End With
            End With
            .Columns.AutoFit
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Rechercher des sujets similaires à "generer tableau vba"