Problème : Export de plusieurs feuilles dans une synthèse

Le 02/09/2015 à 18:35

Bonjour à tous,

Je fais une nouvelle fois appel à vous, qui m'avez déjà grandement aidé auparavant, sur une problématique simple mais dans laquelle je m'emmêle les pinceaux, faute de manque de connaissances sur les tableaux dynamiques en VBA (je pense que la clé est là)..

Je vous joins un fichier pour éclaircir mes explications :

23compilation-de-lignes-dans-feuille-de-synthese.xlsm (40.28 Ko)

J'ai dans ce fichier une feuille SYNTHESE, qui trace l'évolution d'un certain nombre de tâches (dont le nombre est variable), appartenant chacune à un chantier (dont le nombre est variable) ; dans l'exemple je considère 5 chantiers de 10 tâches chacun.

Le but est que l'onglet "SYNTEHSE" soit alimenté automatiquement (contrairement aux onglets Chantiers X, alimentés manuellement)

La condition à remplir pour qu'une tâche et toutes les colonnes associées (colonnes B à V dans mon exemple) "remonte" dans l'onglet de SYNTHESE est que la colonne A "A afficher" indique "Oui" et que la colonne F soit non vide (libellé de la tâche)

Il faudrait donc copier / coller en valeur les données à afficher du chantier 1 dans la feuille de synthèse, puis copier / coller en valeur les données à afficher du chantier 2 dans la feuille de synthèse en les empilant avec les données du chantier 1, etc. (le résultat que j'aimerais obtenir est visible dans mon fichier).

Je pensais à plusieurs solutions :

  • 1) des filtres automatiques réunissant les deux conditions pour chaque chantier ("Oui" en colonne A et non vide en colonne F), puis en dimensionnant la dernière ligne de chaque onglet m'appuyer dessus : mais c'est selon moi trop laborieux et pas une solution très "pérenne"
    2) faire une boucle If for next end if et exporter une à une les lignes réunissant les deux conditions (encore plus laborieux et lent)
    3) réaliser des tableaux dynamiques pour chaque chantier et les copier dans la feuille SYNTHESE en les empilant

Je pense que la solution 3) est la meilleure, mais comme je disais je n'ai pas les connaissances nécessaires sur les tableaux dynamiques VBA... Un petit peu d'aide serait donc la bienvenue...

D'avance, merci, et si ce n'est pas assez clair, je peux apporter des précisions !

Le 03/09/2015 à 12:07

Personne ne veut se pencher sur mon problème ? ...

Le 03/09/2015 à 13:44

Bonjour,

essaye ceci:

un double clic sur la cellule rouge après avoir filtré, copie les lignes dans la synthèse; il faut que tes tableaux de chantier soient parfaitement identique comme c'est le cas actuellement

attention si tu fais 2 fois l'opération ça copie 2 x donc 1 seul double clic.. les couleurs c'est facultatif, juste pour voir ce qui est copier/coller

P.

26compilation-de-lignes-dans-feuille-de-synthese.xlsm (53.76 Ko)
Le 03/09/2015 à 16:37

Bonjour Patrick,

la finalité répond parfaitement à ce que je voulais obtenir, merci beaucoup. Seulement, il ne serait pas possible de faire en sorte qu'un seul bouton central placé sur la feuille SYNTHESE lance les macros pour chaque feuille ? Car j'ai plus que 5 chantiers dans le vrai fichier.

De plus j'ai rajouté une petite gestion d'erreur, si aucune tâche n'est marqué "Oui" cela renvoyait une erreur :

Sub CopierVersSynthese()
Dim Desti As Range
  Selection.AutoFilter

  On Error GoTo Gestion_err
  ActiveSheet.Range("$A$34:$V$450").AutoFilter Field:=1, Criteria1:="Oui"
  ActiveSheet.Range("$A$34:$V$450").AutoFilter Field:=6, Criteria1:="<>""""", _
                                              Operator:=xlAnd
  Range("A35").Select
  With ActiveSheet
    Set plage_filtre = .[_FilterDataBase]
    x = plage_filtre.Rows.Count - 1
    MsgBox plage_filtre.Offset(1, 0).Resize(x).SpecialCells(12).Address
    plage_filtre.Offset(1, 0).Resize(x).Select
    'Selection.Interior.ColorIndex = 18 ' facultatif !!!
  End With
  Set Acopier = Selection
  Set Desti = Sheets("synthese").Range("A65000").End(xlUp).Offset(1)
  Acopier.Copy Destination:=Desti

Gestion_err:
Exit Sub

End Sub

Des idées svp ? Merci

Le 03/09/2015 à 17:01

re,

je ne l'ai pas fais car je trouve ça non pas dangereux, le mot est trop fort, mais ça peut amener des soucis de tout automatiser...

c'est bien sur possible avec une boucle avec le danger de faire plusieurs fois la même copie

Le 03/09/2015 à 22:22

Bonsoir à tous,

En suivant ton raisonnement, vois ceci :

Option Explicit
Option Compare Text

Sub test()
Dim ws As Worksheet, a, b(), Cols, i As Long, j As Long, n As Long
    Application.ScreenUpdating = False
    With Sheets("SYNTHESE").Range("a34").CurrentRegion
        Cols = .Rows(1).Value
        ReDim b(1 To 1000, 1 To UBound(Cols, 2))
        .Offset(1).Clear
        For Each ws In Worksheets
            If ws.Name <> "SYNTHESE" Then
                a = ws.Range("a34").CurrentRegion.Value
                For i = 2 To UBound(a, 1)
                    If a(i, 1) = "oui" And Not IsEmpty(a(i, 6)) Then
                        n = n + 1
                        For j = 1 To UBound(a, 2)
                            b(n, j) = a(i, j)
                        Next
                    End If
                Next
            End If
        Next
        If n > 1 Then
            With .Offset(1).Resize(n)
                .Value = b
                With .CurrentRegion
                    With .Rows(1)
                        .Font.Bold = True
                        .Interior.ColorIndex = 43
                        .BorderAround Weight:=xlThin
                    End With
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .Borders(xlInsideVertical).Weight = xlThin
                    .BorderAround Weight:=xlThin
                    .Columns.AutoFit
                End With
            End With
        Else
            MsgBox "Aucune donnée"
        End If
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 04/09/2015 à 09:22

Bonjour Klin, j'ai un peu de mal avec ta réponse ... Je ne comprends pas les instructions*, et quand je copie/colle ton code et que j'exécute, ton msgbox "Aucune donnée" se lance et la ligne 34 est supprimmée..

*comme celle-ci, même si je me doute que c'est pour dimensionner un tableau dynamique :

ReDim b(1 To 1000, 1 To UBound(Cols, 2))

Pourrais-tu expliciter les lignes ? merci pour ta réponse !

Le 04/09/2015 à 12:19

Bonjour,

remplace par :

With .Offset(2).Resize(n) et ça partira une ligne en dessous de la 34

et teste par exemple:

ReDim b(1 To 1000, 1 To UBound(Cols, 2))

.Offset(2).interior.colorindex = 3

.Offset(2).Resize(n)

par with .offset(2).interior.colorindex = 3

en mettant (2) tu verras les cellules concernées en rouge

Le 04/09/2015 à 20:22

Re julking92,

La propriété CurrentRegion est l'équivalent du raccourci clavier manuel Ctrl + *

Dans ton cas, tu sélectionneras donc la plage à traiter en te plaçant en A34 et en appuyant sur Ctrl + *

Question, la 1ère ligne sélectionnée est-elle bien la ligne 34 soit la ligne d'en-têtes ?

Si oui, le code fonctionne avec le fichier transmis, si non il y a des cellules pleines en ligne 33.

Aussi, rien ne t'empêche de définir la plage à traiter d'une autre manière.

Concernant la variable b, j'aurais pu écrire :

ReDim b(1 To 5000, 1 To 22)

UBound(Cols, 2) est l'indice supérieur de la 2ème dimension de Cols soit ton nombre de colonnes de la feuille Synthèse.

Utilise la fenêtre espion et tu comprendras très vite.

Dernière question : as-tu des problèmes de retranscription des dates ---> inversion jours/mois, perso je n'ai pas vérifié

Dans le code, remplace ceci

If n > 1 Then

par

If n > 0 Then

Klin89

Le 06/09/2015 à 20:14

Re julking92,

Une variante :

La feuille "Synthese" doit être en première position dans ton classeur.

Option Explicit
Option Compare Text

Sub test()
Dim a(), b(), i As Long, j As Long, k As Long, n As Long
    Application.ScreenUpdating = False
    For i = 2 To Sheets.Count
        ReDim Preserve a(1 To i - 1)
        With Sheets(i).Range("a34").CurrentRegion
            a(i - 1) = .Offset(1).Resize(.Rows.Count - 1).Value
        End With
    Next
    ReDim b(1 To 1000, 1 To UBound(a(1), 2))
   ' ReDim b(1 To 1000, 1 To 22)
    For i = 1 To UBound(a)
        For j = 1 To UBound(a(i), 1)
            If (a(i)(j, 1) = "oui") And Not IsEmpty(a(i)(j, 6)) Then
                n = n + 1
                For k = 1 To UBound(a(i), 2)
                    b(n, k) = (a(i)(j, k))
                Next
            End If
        Next
    Next
    With Sheets("SYNTHESE").Range("a34").CurrentRegion
        .Offset(1).Clear
        If n > 0 Then
            With .Offset(1).Resize(n)
                .Value = b
                With .CurrentRegion
                    With .Rows(1)
                        .Font.Bold = True
                        .Interior.ColorIndex = 43
                        .BorderAround Weight:=xlThin
                    End With
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .Borders(xlInsideVertical).Weight = xlThin
                    .BorderAround Weight:=xlThin
                    .Columns.AutoFit
                End With
            End With
        Else
            MsgBox "Aucune donnée"
        End If
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Rechercher des sujets similaires à "probleme export feuilles synthese"