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