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
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