Discussion :

[vin10004]

Bonjour à tous

Je viens demander à la communauté un petit coup de pouce
Pour un travail scolaire de groupe, nous travaillons sur des compteurs d'heures.

Nous avons besoin de travailler sur une macro pour nous automatiser une tâche :
Nous avons besoin d'aide pour extraire sur chaque feuille d'un fichier Excel le nombre contenu dans 12 cellules (par feuilles) et les copier sur une dernière feuille "SYNTHESE"
Il y à + de 100 feuilles alors a la main aie aie aie !

Merci à vous pour l'aide et les conseils

[Philippe Tulliez]

Bonjour,

extraire sur chaque feuille d'un fichier Excel le nombre contenu dans 12 cellules (par feuilles)

Plus on est précis, plus on a de chance d'avoir une réponse rapide et pertinente.
Pour les 12 cellules

• combien de colonnes, de lignes
• la première ligne contient-elle une ou plusieurs étiquettes de colonnes
• à quelle adresse commence la première cellule et cette adresse est-elle la même dans chaque feuille
• etc.

[vin10004]

Bonjour Philippe,
Je vais tâcher de faire plus attention et d'être exhaustif.

Pour les 12 cellules :
Elles sont communes à toutes les feuilles : Colonne "R" en constante et ligne 34, 69, 97,132, 160, 188,223,251,279,314,342 et 370
L'extraction est donc : sur toutes les feuilles extraire les cellules $R$34,69,97...


Merci à vous

[vinc_bilb]

Bonjour,

Ce n'est pas forcément optimisé, mais vous pouvez adapter et essayer le code ci-dessous. Il y a peut-être plus efficace

Sub Test: procédure appelante, on sauve le résultat dans ResAR (tableau)
Extract_Data: on sort sous forme de tableau les valeurs des Range (spécifiées par l'argument SrcRngAd, ici "A3,A5,A7, A11") pour toutes les feuilles du classeur et on retourne ce tableau

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub Test()
 
Dim ResAR As Variant
 
    ResAR = Extract_Data("A3,A5,A7, A11")   'A remplacer par "R" en constante et ligne 34, 69, 97,132, 160, 188,223,251,279,314,342 et 370
 
End Sub
Function Extract_Data(SrcRngAd As String) As Variant
 
Dim Wsh As Worksheet
Dim SrcRng As Range, Cl As Range
Dim ExtrAR As Variant
Dim ClIndI As Integer, CntClI As Integer
 
 
' Initialisation
    'On dimensionne le tableau résultat en fonction du nombre de feuilles et d'adresses passées dans SrcRngAd
    ReDim ExtrAR(1 To ThisWorkbook.Worksheets.Count, 1 To UBound(Split(SrcRngAd, ",", , vbTextCompare), 1) + 1)
 
' Parcours toutes les sheets et sauve le résultat du SrcRng dans le tableau
    For Each Wsh In ThisWorkbook.Worksheets
 
        CntClI = 0
 
        Set SrcRng = Wsh.Range(SrcRngAd)
 
        For Each Cl In SrcRng.Cells
 
            CntClI = CntClI + 1
            ExtrAR(Wsh.Index, CntClI) = Cl.Value
 
        Next Cl
 
    Next Wsh
   ' On retourne le résultat
    Extract_Data = ExtrAR
 
End Function

[vin10004]

Merci,

On à beau modifier et jongler avec la formule rien ne change,
La feuille reste désespérément vide.

[Philippe Tulliez]

Bonjour,
Il faut modifier la valeur de la constante nommée rngAddress pour y placer les bonnes adresses de cellules
On considère dans cette procédure qu'il n'y a pas d'étiquette de colonne dans la colonne cible.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Regroupement()
 Const rngAddress As String = "R34,R69,R97"
 Const shtTargetName As String = "synthese"
 Dim sht As Worksheet, flag As Boolean
 With ThisWorkbook
  .Worksheets(shtTargetName).Cells.Clear
  For Each sht In .Worksheets
   If Trim(LCase(sht.Name)) <> shtTargetName Then
    sht.Range(rngAddress).Copy .Worksheets(shtTargetName).Range("A" & Application.Rows.Count).End(xlUp).Offset(Abs(flag)): flag = True
   End If
  Next
 End With
End Sub

[Theze]

Bonjour,

Une autre piste :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Sub Test()
 
    Dim Fe As Worksheet
    Dim Tbl
    Dim Tablo(1 To 12)
    Dim I As Integer
    Dim J As Integer
 
    Tbl = Array(34, 69, 97, 132, 160, 188, 223, 251, 279, 314, 342, 370)
 
    For Each Fe In Worksheets
 
        If Fe.Name <> "SYNTHESE" Then
 
            For I = 0 To UBound(Tbl): Tablo(I + 1) = Fe.Range("R" & Tbl(I)).Value: Next I
 
            J = J + 1
 
            Worksheets("SYNTHESE").Range("A" & J & ":L" & J).Value = Tablo()
 
        End If
 
    Next Fe
 
End Sub

[vin10004]

Bonjour,

Merci à vous !
C'est nickel et si j'ai bien compris entre :

End If
Next
End With

Je peux rajouter une fonction ?
J'aimerais en plus rajouter la fonction "Prend le nom de la feuille 1 et saute 11 lignes puis prend le nom de la feuille 2 et saute 11 ligne etc.."
Tout en l'intégrant dans le macro précédant.

[Philippe Tulliez]

Bonjour,

Je peux rajouter une fonction ?
J'aimerais en plus rajouter la fonction "Prend le nom de la feuille 1 et saute 11 lignes puis prend le nom de la feuille 2 et saute 11 ligne etc.."
Tout en l'intégrant dans le macro précédant.

Tout est possible, il faut juste savoir ce que l'on veut faire et ensuite réfléchir à la meilleure manière d'effectuer le travail.

ps

Prend le nom de la feuille 1 et saute 11 lignes puis prend le nom de la feuille 2 et saute 11 ligne etc..

Finalement ce n'était pas pareil pour toutes les feuilles

[vin10004]

Prend le nom de la feuille 1 et saute 11 lignes puis prend le nom de la feuille 2 et saute 11 lignes, etc..

Effectivement, je pensais que vous parliez de la récurrence.

Alors je vais reprendre exhaustivement

Je possède un fichier excel rassemblant des heures de travails de x collaborateurs.
A chaque fin de moi une colonne ($R$31, .. et ce 12 fois (mois de l'année).
Chaque feuille correspondant à un collaborateur.

J'ai besoin d'une dernière feuille qui me dise collaborateur1 (nom de la feuille) en B2 (par exemple); En B3 que ce soit les heures de janvier et du coup en B4 les heures de Fevrier...
Collaborateur2 sera donc en C2 avec en C3 les heures de janvier..

Avez-vous compris le sens de ma demande ?

Merci à vous, pour votre aide, sincèrement.

[Philippe Tulliez]

Bonjour,
Je pense qu'avec les réponses déjà obtenues tu devrais déjà pouvoir réaliser ce travail non ?
Le nom de la feuille (sht.Name) est déjà évoqué dans la procédure que j'ai proposée.
C'est un club d'entraide. Il y a lieu de faire des tests, voir ce qui ne va pas, etc. et ensuite revenir pour expliquer où l'on a un problème.

[vin10004]

Merci pour l'aide

J'ai réussi et suis assez content, mais je n'arrive pas à paramétrer une commande :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Regroupement()
 Const rngAddress As String = "M1"
 Const shtTargetName As String = "synthese"
 Dim sht As Worksheet, flag As Boolean
 With ThisWorkbook
  .Worksheets(shtTargetName).Cells.Clear
  For Each sht In .Worksheets
   If Trim(LCase(sht.Name)) <> shtTargetName Then
    sht.Range(rngAddress).Copy .Worksheets(shtTargetName).Range("A2" & Application.Rows.Count).End(xlUp).Offset(Abs(flag)): flag = True
   End If
  Next
 End With
 End Sub

J'ai besoin que la copie de donnée soit apposé en "A2" laissant ainsi la ligne 1 vierge.

Concernant celui-ci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Heures()
     Dim Fe As Worksheet
    Dim Tbl
    Dim Tablo(1 To 12)
    Dim I As Integer
    Dim J As Integer
     Tbl = Array(34, 69, 97, 132, 160, 188, 223, 251, 279, 314, 342, 370)
     For Each Fe In Worksheets
         If Fe.Name <> "SYNTHESE" Then
             For I = 0 To UBound(Tbl): Tablo(I + 1) = Fe.Range("R" & Tbl(I)).Value: Next I
             J = J + 1
             Worksheets("SYNTHESE").Range("B" & J & ":M" & J).Value = Tablo()
         End If
     Next Fe
 End Sub

J'ai réussi à le comprendre et à l'ajuster à mes besoins, mais ici je ne vois pas la possibilité d'appliquer la commande débute en "B2".

Merci