Discussion :

[LIFATOUCH]

Bonjour,

Je reviens sur le forum après plusieurs tentatives.

J'ai réussi à adapter un code. Il fonctionne et effectue le calcul demandé mais je souhaiterai l'appliquer sur plusieurs fichiers en le mettant dans un classeur à part et insérer un bouton qui me permettra de l'exécuter sur l'ensemble des classeurs

mais malheureusement quand j'essaye d'intéger la focntion DIR ca ne marche plus et j'ai du mal à voir d'où vient le probléme.


Je joins mon code sans la fonction DIR

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
  Sub extraction_calcul()
 
Dim nl As Integer
Dim i As Integer
Dim j As Integer
Dim nb_listedoc As Long
Dim nbligne As Long
 
nbligne = Application.CountA(Sheets("Sogelink").Range("G:G"))
 
Set myrange = Sheets("Sogelink").Range("G2:G" & nbligne)
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
 
Worksheets("Sogelink").Copy before:=Worksheets("Liste_documents")
 
ActiveSheet.Name = "Copie fichier de base"
 
Sheets("Copie fichier de base").Range("A:F").Delete
Sheets("Copie fichier de base").Range("B:I").Delete
Sheets("Copie fichier de base").Range("C:D").Delete
Sheets("Copie fichier de base").Range("D:E").Delete
Sheets("Copie fichier de base").Range("F:F").Delete
 
With Sheets("Copie fichier de base")
 
Range("A:E").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
 
Sheets("Copie fichier de base").Range("A1:E65000").AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("Copie fichier de base").Range("A1:A65000"), copytorange:=Sheets("Liste_documents").Range("A1:E1"), Unique:=True
 
End With
 
With Sheets("Liste_documents")
 
nb_listedoc = Application.CountA(Sheets("Liste_documents").Range("A:A"))
 
For nl = 2 To nb_listedoc
 
Sheets("Liste_documents").Columns("F").Cells(nl) = Application.WorksheetFunction.CountIfs(myrange, Sheets("Liste_documents").Columns("A").Cells(nl))
 
Next nl
 
Sheets("Liste_documents").Columns("F").Cells(1) = "nbre_de_lignes"
 
End With
 
With Sheets("Liste_documents")
 
For i = 2 To nb_listedoc
 
Sheets("Liste_documents").Cells(i, 7).Value = Sheets("Liste_documents").Cells(i, 4).Value * Sheets("Liste_documents").Cells(i, 6).Value
 
Sheets("Liste_documents").Cells(i, 8).Value = Sheets("Liste_documents").Cells(i, 5).Value * Sheets("Liste_documents").Cells(i, 6).Value
 
Next i
 
Sheets("Liste_documents").Columns("G").Cells(1) = "Total pages lignes"
 
Sheets("Liste_documents").Columns("H").Cells(1) = "Total unit?s lignes"
 
End With
 
Sheets("Copie fichier de base").Delete
 
ActiveWorkbook.Close SaveChanges:=True
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

Merci de votre aide

cordialement,

[Menhir]

mais malheureusement quand j'essaye d'intéger la focntion DIR ca ne marche plus et j'ai du mal à voir d'où vient le probléme.

Bin... si tu n'es pas plus descriptif sur ce qui "ne marche pas", on risque aussi à avoir beaucoup de difficultés à comprendre d'où ça vient.
(comme il t'a déjà été dit)

Je joins mon code sans la fonction DIR

Si tu ne montres que ce qui fonctionne et que tu retires ce qui ne fonctionne pas, comment veux-tu qu'on sache comment résoudre le problème ?

Code :

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

1
2
3
4
5
Sheets("Copie fichier de base").Range("A:F").Delete
Sheets("Copie fichier de base").Range("B:I").Delete
Sheets("Copie fichier de base").Range("C:D").Delete
Sheets("Copie fichier de base").Range("D:E").Delete
Sheets("Copie fichier de base").Range("F:F").Delete

Etrange formulation...

[LIFATOUCH]

Bonjour,

J'ai pu résoudre le problème en contournant, j'avais une erreur dans le set que j'avais mis et qui me bloquer, je l'ai mis en commentaire et insérer directement la valeur dans mon countifs

Pour ceux qui seraient intérressés une petite explication et ci-dessous le code final

le code fonctionne et permet de créer une copie du premier onglet, de ne conserver que certaines colonnes et d'appliquer un filtre avancé sur le 2ième onglet en mettant la sortie sans doublons sur le 3ième onglet et de compter le nombre de lignes selon la colonne A du dernier onglet

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
 
 
Sub Autres_colonnes()
 
Dim f As String
Dim nl As Integer
Dim i As Integer
Dim j As Integer
Dim nb_listedoc As Long
Dim nbligne As Long
 
'parcourir tous les fichiers
ChDir "D:\Users\ncisse\Desktop\Dossier\Ddes Autres\DDe_Ingrid"
f = Dir("*.xlsm")
 
Do While Len(f) > 0
 
Workbooks.Open f
 
 
nbligne = Application.CountA(Sheets("Sogelink").Range("G:G"))
 
'Set myrange = Sheets("Sogelink").Range("G2:G" & nbligne)
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
 
 
Worksheets("Sogelink").Copy before:=Worksheets("Liste_documents")
 
ActiveSheet.Name = "Copie fichier de base"
 
Sheets("Copie fichier de base").Range("A:F").Delete
Sheets("Copie fichier de base").Range("B:I").Delete
Sheets("Copie fichier de base").Range("C:D").Delete
Sheets("Copie fichier de base").Range("D:E").Delete
Sheets("Copie fichier de base").Range("F:F").Delete
 
With Sheets("Copie fichier de base")
 
Range("A:E").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
 
Sheets("Copie fichier de base").Range("A1:E65000").AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("Copie fichier de base").Range("A1:A65000"), copytorange:=Sheets("Liste_documents").Range("A1:E1"), Unique:=True
 
End With
 
With Sheets("Liste_documents")
 
nb_listedoc = Application.CountA(Sheets("Liste_documents").Range("A:A"))
 
For nl = 2 To nb_listedoc
 
Sheets("Liste_documents").Columns("F").Cells(nl) = Application.WorksheetFunction.CountIfs(Sheets("Sogelink").Range("G2:G" & nbligne), Sheets("Liste_documents").Columns("A").Cells(nl))
 
Next nl
 
Sheets("Liste_documents").Columns("F").Cells(1) = "nbre_de_lignes"
 
End With
 
With Sheets("Liste_documents")
 
For i = 2 To nb_listedoc
 
Sheets("Liste_documents").Cells(i, 7).Value = Sheets("Liste_documents").Cells(i, 4).Value * Sheets("Liste_documents").Cells(i, 6).Value
 
Sheets("Liste_documents").Cells(i, 8).Value = Sheets("Liste_documents").Cells(i, 5).Value * Sheets("Liste_documents").Cells(i, 6).Value
 
Next i
 
Sheets("Liste_documents").Columns("G").Cells(1) = "Total pages lignes"
 
Sheets("Liste_documents").Columns("H").Cells(1) = "Total unit?s lignes"
 
End With
 
Sheets("Copie fichier de base").Delete
 
ActiveWorkbook.Close SaveChanges:=True
 
f = Dir
Loop
 
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
 
End Sub