problème de code complexe

  • Initiateur de la discussion sylvain
  • Date de début
S

sylvain

Guest
bonjour à tous,

j'essaye de faire dans une cellule d'un classeur la moyenne de plusieurs mêmes cellules situés dans plusieurs classeurs fermés : jusque là pas de problème : j'ai adapté un code que j'ai trouvé sur ce forum. Voici le code pour ceux que ça intéresse :

Option Explicit
Option Base 1
Sub moyennegroupe1()
Dim X As Integer, NbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Dim Dossier As String

Dim Valeur As Double
Dim Valeurfinale As Double


Dossier = 'c:\\simoporc\\sauvegarde\\Groupe1'

Application.ScreenUpdating = False




'Direction = Dir(ThisWorkbook.Path & '\\*.xls')
Direction = Dir(Dossier & '\\*.xls')

Do While Len(Direction) > 0 'liste tous les classeurs du repertoire
NbFichiers = NbFichiers + 1
ReDim Preserve Tableau(1 To NbFichiers)
Tableau(NbFichiers) = Direction
Direction = Dir()
Loop
Worksheets('synthèse').Cells(15, 7).Value = 0
If NbFichiers > 0 Then

For X = 1 To NbFichiers 'boucles sur les classeurs

' pour ne pas prendre en compte le classeur contenant la macro (synthese)
If Tableau(X) <> ThisWorkbook.Name Then

'Nb de truies


For Y = 1 To 1 'boucle sur les produits à récupérer
'recupere la valeur deja existante dans le tableau de synthese

Valeur = ActiveSheet.Cells(Y + 14, 7)

With ActiveSheet.Cells(Y + 14, 7) 'ajout des nouvelles valeurs
.Formula = '='' & Dossier & '\\[' & Tableau(X) & ']' & 'bdd' & ''!' _
& Cells(Y + 8, 5).Address
.Value = .Value + Valeur
End With

Next Y

End If

Next X
Valeurfinale = ActiveSheet.Cells(15, 7).Value
Worksheets('synthèse').Cells(15, 7).Value = Valeurfinale / (NbFichiers)


End If

Application.ScreenUpdating = True
End Sub


Par contre, je souhaiterais exécuter ce code pour plusieurs autres cellules en même temps mais je n'y arrive pas. J'ai essayé de mettre à bout deux fois le code ci dessous mais ça ne marche pas pourtant VBA ne m'indique pas d'erreur dans le code : je ne comprends pas.
Merci du coup de main.

Voici le code qui ne marche pas :


Option Explicit
Option Base 1
Sub moyennegroupe1()
Dim X As Integer, NbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Dim Dossier As String

Dim Valeur As Double
Dim Valeurfinale As Double


Dossier = 'c:\\simoporc\\sauvegarde\\Groupe1'

Application.ScreenUpdating = False




'Direction = Dir(ThisWorkbook.Path & '\\*.xls')
Direction = Dir(Dossier & '\\*.xls')

Do While Len(Direction) > 0 'liste tous les classeurs du repertoire
NbFichiers = NbFichiers + 1
ReDim Preserve Tableau(1 To NbFichiers)
Tableau(NbFichiers) = Direction
Direction = Dir()
Loop
Worksheets('synthèse').Cells(15, 7).Value = 0
If NbFichiers > 0 Then

For X = 1 To NbFichiers 'boucles sur les classeurs

' pour ne pas prendre en compte le classeur contenant la macro (synthese)
If Tableau(X) <> ThisWorkbook.Name Then

'Nb de truies


For Y = 1 To 1 'boucle sur les produits à récupérer
'recupere la valeur deja existante dans le tableau de synthese

Valeur = ActiveSheet.Cells(Y + 14, 7)

With ActiveSheet.Cells(Y + 14, 7) 'ajout des nouvelles valeurs
.Formula = '='' & Dossier & '\\[' & Tableau(X) & ']' & 'bdd' & ''!' _
& Cells(Y + 8, 5).Address
.Value = .Value + Valeur
End With

Next Y

End If

Next X
Valeurfinale = ActiveSheet.Cells(15, 7).Value
Worksheets('synthèse').Cells(15, 7).Value = Valeurfinale / (NbFichiers)


End If

' % de truies productives


Do While Len(Direction) > 0 'liste tous les classeurs du repertoire
NbFichiers = NbFichiers + 1
ReDim Preserve Tableau(1 To NbFichiers)
Tableau(NbFichiers) = Direction
Direction = Dir()
Loop

Worksheets('synthèse').Cells(16, 7).Value = 0
If NbFichiers > 0 Then
For X = 1 To NbFichiers 'boucles sur les classeurs

' pour ne pas prendre en compte le classeur contenant la macro (synthese)
If Tableau(X) <> ThisWorkbook.Name Then




For Y = 1 To 1 'boucle sur les produits à récupérer
'recupere la valeur deja existante dans le tableau de synthese

Valeur = ActiveSheet.Cells(Y + 15, 7)

With ActiveSheet.Cells(Y + 15, 7) 'ajout des nouvelles valeurs
.Formula = '='' & Dossier & '\\[' & Tableau(X) & ']' & 'bdd' & ''!' _
& Cells(Y + 8, 10).Address
.Value = .Value + Valeur
End With

Next Y

End If

Next X
Valeurfinale = ActiveSheet.Cells(16, 7).Value
Worksheets('synthèse').Cells(16, 7).Value = Valeurfinale / (NbFichiers)


End If




Application.ScreenUpdating = True
End Sub
 

MichelXld

XLDnaute Barbatruc
bonjour Sylvain

tu peux essayer une adaptation de ce style


Code:
Option Base 1
Sub moyennegroupe1()
Dim X As Integer, NbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Dim Dossier As String
Dim Valeur As Double
Dim Valeurfinale As Double


Dossier = 'c:simoporcsauvegardeGroupe1'
Application.ScreenUpdating = False

Direction = Dir(Dossier & '\\*.xls')

Do While Len(Direction) > 0 'liste tous les classeurs du repertoire
NbFichiers = NbFichiers + 1
ReDim Preserve Tableau(1 To NbFichiers)
Tableau(NbFichiers) = Direction
Direction = Dir()
Loop

Worksheets('synthèse').Cells(15, 7).Value = 0
Worksheets('synthèse').Cells(16, 7).Value = 0


If NbFichiers > 0 Then

For X = 1 To NbFichiers 'boucles sur les classeurs
' pour ne pas prendre en compte le classeur contenant la macro (synthese)
If Tableau(X) <> ThisWorkbook.Name Then

For Y = 1 To 2

Valeur = ActiveSheet.Cells(Y + 14, 7)

With ActiveSheet.Cells(Y + 14, 7) 'ajout des nouvelles valeurs
.Formula = '='' & Dossier & '\\[' & Tableau(X) & ']' & 'Feuil1' & ''!' _
& Cells(9, 5 * Y).Address
.Value = .Value + Valeur
End With

Next Y

End If

Next X
End If

Valeurfinale = ActiveSheet.Cells(15, 7).Value
Worksheets('synthèse').Cells(15, 7).Value = Valeurfinale / (NbFichiers)

Valeurfinale = ActiveSheet.Cells(16, 7).Value
Worksheets('synthèse').Cells(16, 7).Value = Valeurfinale / (NbFichiers)

Application.ScreenUpdating = True
End Sub


bonne soiree
MichelXld
 

Discussions similaires

Réponses
9
Affichages
375
Réponses
4
Affichages
167
Réponses
13
Affichages
561
Réponses
1
Affichages
228

Statistiques des forums

Discussions
299 878
Messages
1 979 749
Membres
206 856
dernier inscrit
Proux