Report de données

eridus

eridus

XLDnaute Junior
Bonjour à tous, chère communauté Excel,

Je reviens vers vous aujourd'hui pour une question qui me semble assez compliquée.

Pour mieux me faire comprendre, je vous ai joint un fichier en exemple. Il s'agit d'un fichier de compte d'entreprise avec prévisionnel.

Comme vous pouvez le voir dans l'onglet "Détail Sommes provisionnées", il y a un numéro à coté des titres de chaque rubrique (en vert).

Également, lorsque vous allez dans l'onglet "juin", il y a des chiffres dans la colonne B.

Voilà ma question :

Serait-il possible que, à partir du moment où on indique un chiffre dans la colonne B de l'onglet "juin", on puisse retrouver le libellé (colonne C) et le débit (colonne D) ou le crédit (colonne E) dans l'onglet "Détail Sommes provisionnées" et dans leur colonnes respectives (B, C ou D), mais aussi dans leur rubrique de destination déterminée par le chiffre indiqué dans la colonne B de l'onglet "juin" ? :confused:

J'espère que ma question est claire ! Sinon, n'hésitez pas à me demander des précisions.

Une fois de plus je me remet entre vos mains expertes en espérant que vous réussirez à optimiser encore une fois un de mes nombreux fichiers Excel.

Par avance, un grand merci à vous.

Cordialement,

Eridus
 

Pièces jointes

  • Tableau d'essai.xlsx
    473.5 KB · Affichages: 57
  • Tableau d'essai.xlsx
    473.5 KB · Affichages: 57
  • Tableau d'essai.xlsx
    473.5 KB · Affichages: 51
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Report de données

Re,

Voici la macro pour traiter les 12 mois de l'année :

Code: 
Private Sub Worksheet_Activate()
Dim a, n As Byte, i As Variant, j As Variant, w As Worksheet, k As Long
a = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", _
  "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
Application.ScreenUpdating = False
For n = 1 To 13 'à adapter éventuellement
  i = Application.Match("*(" & n & ")", [B:B], 0)
  If IsNumeric(i) Then
    j = Application.Match("TOTAL*", Range(Cells(i + 1, 2), Range("B" & Rows.Count)), 0)
    If IsNumeric(j) Then
      If j > 3 Then Rows(i + 2).Resize(j - 3).Delete 'RAZ
      For j = 11 To 0 Step -1 'de décembre à janvier
        Set w = Nothing
        On Error Resume Next 'si la feuille n'existe pas
        Set w = Sheets(a(j))
        On Error GoTo 0
        If Not w Is Nothing Then
          For k = w.Range("B" & w.Rows.Count).End(xlUp).Row To 11 Step -1
            If w.Cells(k, 2) = n Then
              Rows(i + 2).Insert
              Cells(i + 2, 2).Resize(, 3) = w.Cells(k, 3).Resize(, 3).Value
              Cells(i + 2, 3).Resize(, 2).NumberFormat = "#,###.00 €" 'au cas où
            End If
          Next k
        End If
      Next j
    End If
  End If
Next n
End Sub
A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Report de données

Bonjour eridus, le forum,

Juste 2 remarques.

S'il y a beaucoup de données dans les feuilles des mois le traitement sera long.

Dans ce cas, au lieu d'une Worksheet_Activate, exécutez la macro par un bouton (ActiveX) :

Code: 
Private Sub CommandButton1_Click()
Par ailleurs, c'est mieux, corrigez le format monétaire => "#,##0.00 €"

Bonne journée et A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Report de données

Re,

La durée d'exécution est diminuée si l'on applique le format monétaire sur les colonnes c et D en fin de macro :

Code: 
Private Sub Worksheet_Activate() 'Private Sub CommandButton1_Click()
Dim a, n As Byte, i As Variant, j As Variant, w As Worksheet, k As Long
a = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", _
  "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For n = 1 To 13 'à adapter éventuellement
  i = Application.Match("*(" & n & ")", [B:B], 0)
  If IsNumeric(i) Then
    j = Application.Match("TOTAL*", Range(Cells(i + 1, 2), Range("B" & Rows.Count)), 0)
    If IsNumeric(j) Then
      If j > 3 Then Rows(i + 2).Resize(j - 3).Delete 'RAZ
      For j = 11 To 0 Step -1 'de décembre à janvier
        Set w = Nothing
        On Error Resume Next 'si la feuille n'existe pas
        Set w = Sheets(a(j))
        On Error GoTo 0
        If Not w Is Nothing Then
          For k = w.Range("B" & w.Rows.Count).End(xlUp).Row To 11 Step -1
            If w.Cells(k, 2) = n Then
              Rows(i + 2).Insert
              Cells(i + 2, 2).Resize(, 3) = w.Cells(k, 3).Resize(, 3).Value
            End If
          Next k
        End If
      Next j
    End If
  End If
Next n
[C:D].NumberFormat = "#,##0.00 €" 'au cas où
Application.Calculation = xlCalculationAutomatic
End Sub
Edit : ne faudrait-il pas copier aussi les dates ?

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Report de données

Re,

Une solution plus rapide mais plus sophistiquée avec les tableaux VBA t et b :

Code: 
Private Sub Worksheet_Activate() 'Private Sub CommandButton1_Click()
Dim a, n As Byte, i, j, w As Worksheet, t, h&, k&, b()
a = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", _
  "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For n = 1 To 13 'à adapter éventuellement
  i = Application.Match("*(" & n & ")", [B:B], 0)
  If IsNumeric(i) Then
    j = Application.Match("TOTAL*", Range(Cells(i + 1, 2), Range("B" & Rows.Count)), 0)
    If IsNumeric(j) Then
      If j > 3 Then Rows(i + 2).Resize(j - 3).Delete 'RAZ
      For j = 11 To 0 Step -1 'de décembre à janvier
        Set w = Nothing
        On Error Resume Next 'si la feuille n'existe pas
        Set w = Sheets(a(j))
        On Error GoTo 0
        If Not w Is Nothing Then
          t = w.Range("B11:E" & w.Range("B" & w.Rows.Count).End(xlUp).Row).Value2
          h = 0
          For k = 1 To UBound(t)
            If t(k, 1) = n Then
              h = h + 1
              ReDim Preserve b(1 To 3, 1 To h)
              b(1, h) = t(k, 2): b(2, h) = t(k, 3): b(3, h) = t(k, 4)
            End If
          Next k
          If h Then
            Rows(i + 2).Resize(h).Insert 'insertion de h lignes
            Cells(i + 2, 2).Resize(h, 3) = Application.Transpose(b)
          End If
        End If
      Next j
    End If
  End If
Next n
[C:D].NumberFormat = "#,##0.00 €" 'au cas où
Application.Calculation = xlCalculationAutomatic
End Sub
On gagne environ 40% sur la durée d'exécution.

Nota : .Value2 est utilisée dans la définition de t à cause des formats monétaires : elle permet de récupérer les valeurs numériques.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Report de données

Re,

Enfin, avec le tableau c, cette macro récupère les dates en colonne A :

Code: 
Private Sub Worksheet_Activate() 'Private Sub CommandButton1_Click()
Dim a, n As Byte, i, j, w As Worksheet, t, h&, k&, b(), c()
a = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", _
  "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For n = 1 To 13 'à adapter éventuellement
  i = Application.Match("*(" & n & ")", [B:B], 0)
  If IsNumeric(i) Then
    j = Application.Match("TOTAL*", Range(Cells(i + 1, 2), Range("B" & Rows.Count)), 0)
    If IsNumeric(j) Then
      If j > 3 Then Rows(i + 2).Resize(j - 3).Delete 'RAZ
      For j = 11 To 0 Step -1 'de décembre à janvier
        Set w = Nothing
        On Error Resume Next 'si la feuille n'existe pas
        Set w = Sheets(a(j))
        On Error GoTo 0
        If Not w Is Nothing Then
          t = w.Range("A11:E" & w.Range("B" & w.Rows.Count).End(xlUp).Row).Value2
          h = 0
          For k = 1 To UBound(t)
            If t(k, 2) = n Then
              h = h + 1
              ReDim Preserve b(1 To 3, 1 To h)
              ReDim Preserve c(1 To h)
              b(1, h) = t(k, 3): b(2, h) = t(k, 4): b(3, h) = t(k, 5)
              c(h) = t(k, 1)
            End If
          Next k
          If h Then
            Rows(i + 2).Resize(h).Insert 'insertion de h lignes
            Cells(i + 2, 2).Resize(h, 3) = Application.Transpose(b)
            Cells(i + 2, 1).Resize(h) = Application.Transpose(c)
          End If
        End If
      Next j
    End If
  End If
Next n
[C:D].NumberFormat = "#,##0.00 €" 'au cas où
[A:A].NumberFormat = "dd-mmmm-yy"
Application.Calculation = xlCalculationAutomatic
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Report de données

Re,

Je n'avais pas fait attention : il y a des formules volatiles avec DECALER en colonne H de la feuille de mois.

Pour éviter leur recalcul répété pendant l'exécution de la macro, il faut passer en calcul manuel avec :

Code: 
Application.Calculation = xlCalculationManual
Je modifie en conséquence les posts #18 #19 et #20.

A+
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
XL 2019 Regroupement et report de données
Réponses
2
Affichages
199
AtTheOne
AtTheOne
M
  • Résolu(e)
Microsoft 365 Prochain numéro
Réponses
2
Affichages
228
Marvin57
M
Léna124
  • Question
Microsoft 365 Ventilation budget par mois
Réponses
4
Affichages
371
Léna124
Léna124
WTF
  • Résolu(e)
Microsoft 365 Créer une base de données à partir de 2 onglets
Réponses
3
Affichages
270
WTF
WTF
R
  • Résolu(e)
XL 2019 amélioration d'une macro (actualisation auto et automatisation)
Réponses
11
Affichages
360
rh.finances
R
M
  • Question
XL pour MAC Report de valeur
Réponses
10
Affichages
298
JHA
J
P
  • Question
XL 2016 identifier chaine de caractère dans une cellule et ramener une donnée d'une table de correspondance
Réponses
5
Affichages
296
pmid20
P
M
  • Résolu(e)
Microsoft 365 Code pour transfert
2
Réponses
15
Affichages
421
Marvin57
M
R
  • Résolu(e)
Autres Problème de duplication de boutons
Réponses
3
Affichages
116
fanfan38
fanfan38
J
  • Question
Microsoft 365 extraction VBA avec formule si
Réponses
10
Affichages
370
Phil69970
Phil69970

Membres actuellement en ligne

23 membres et 348 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 440
Messages
2 088 454
Membres
103 855
dernier inscrit
davignon