Bonjour a tous
Je souhaite rassembler les informations de plusieurs classeur excel ,pour cela j ai besoin d' une vba qui me liste les fichiers sur une colonne B (ex:de B6 a A1500)dans un classeur A
Puis ouvrir le fichier placer en B6de ce classeur A et copier une serie de cellule de ce fichier dans les colonnes C, D et E de ce classeur .et faire ainsi de suite pour tout les fichiers de ma liste.
Rq les cellules a copier sont trois : on doit les chercher
Première cellule c'est numéro qui commence par :29-20-xxx
Deuxième cellule c'est numéro qui commence par :45-30-xxx
Troisième cellule c'est numéro qui commence par :81-10-xxx
Voila, j'ai fait un petit essai mais il n'est pas finaliser et je suis bloquer
SVP aider moi
Sub chercheFichiersFermesV03()
Dim X As Integer, nbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Application.ScreenUpdating = False
Direction = Dir("C:\Documents and Settings\Bureau\projet\*.xls") 'adapter chemin repertoire
Do While Len(Direction) > 0
nbFichiers = nbFichiers + 1
ReDim Preserve Tableau(1 To nbFichiers)
Tableau(nbFichiers) = Direction
Direction = Dir()
Loop
If nbFichiers > 0 Then
For X = 1 To nbFichiers
If Tableau(X) <> ThisWorkbook.Name Then
Y = Y + 1
With ActiveSheet.Cells(Y, 1)
.Formula = "='C:\Documents and Settings\astu\Bureau\projet\FD traité\[" & Tableau(X) & "]Feuil1" & "'!" & "B20"
.Value = .Value
End With
End If
Next X
End If
Application.ScreenUpdating = True
End Sub
Je souhaite rassembler les informations de plusieurs classeur excel ,pour cela j ai besoin d' une vba qui me liste les fichiers sur une colonne B (ex:de B6 a A1500)dans un classeur A
Puis ouvrir le fichier placer en B6de ce classeur A et copier une serie de cellule de ce fichier dans les colonnes C, D et E de ce classeur .et faire ainsi de suite pour tout les fichiers de ma liste.
Rq les cellules a copier sont trois : on doit les chercher
Première cellule c'est numéro qui commence par :29-20-xxx
Deuxième cellule c'est numéro qui commence par :45-30-xxx
Troisième cellule c'est numéro qui commence par :81-10-xxx
Voila, j'ai fait un petit essai mais il n'est pas finaliser et je suis bloquer
SVP aider moi
Sub chercheFichiersFermesV03()
Dim X As Integer, nbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Application.ScreenUpdating = False
Direction = Dir("C:\Documents and Settings\Bureau\projet\*.xls") 'adapter chemin repertoire
Do While Len(Direction) > 0
nbFichiers = nbFichiers + 1
ReDim Preserve Tableau(1 To nbFichiers)
Tableau(nbFichiers) = Direction
Direction = Dir()
Loop
If nbFichiers > 0 Then
For X = 1 To nbFichiers
If Tableau(X) <> ThisWorkbook.Name Then
Y = Y + 1
With ActiveSheet.Cells(Y, 1)
.Formula = "='C:\Documents and Settings\astu\Bureau\projet\FD traité\[" & Tableau(X) & "]Feuil1" & "'!" & "B20"
.Value = .Value
End With
End If
Next X
End If
Application.ScreenUpdating = True
End Sub
