Alex90000
Nouveau membre
Bonjour à tous,
Je suis novice sur ce forum et j'ai besoin de votre aide.
Je voudrai créer un programme qui puisse être capable d'aller chercher des infos dans plusieurs classeurs Excel (en fonction d'un n° de semaine choisit) puis, me coller ces infos dans un fichier commun ("MC_Commun").
Tous les classeurs se trouve dans le même dossier.
J'ai réussi avec un 1 fichier (MC_Shootage) mais, je ne sais pas comment gérer avec plusieurs fichiers ? Existe t'il une fonction multiFichier ou qqch comme ça?
Voici mon pgm:
Merci à tous ceux qui pourront m'aider!!
Je suis novice sur ce forum et j'ai besoin de votre aide.
Je voudrai créer un programme qui puisse être capable d'aller chercher des infos dans plusieurs classeurs Excel (en fonction d'un n° de semaine choisit) puis, me coller ces infos dans un fichier commun ("MC_Commun").
Tous les classeurs se trouve dans le même dossier.
J'ai réussi avec un 1 fichier (MC_Shootage) mais, je ne sais pas comment gérer avec plusieurs fichiers ? Existe t'il une fonction multiFichier ou qqch comme ça?
Voici mon pgm:
Code:
Sub Dechet_Finition_Hebdo()
'Identification des chemins et des fichiers
Dim Chemin As String, WbDestination As Workbook, WbSource As Workbook
Dim Fichier As String
Dim Semaine As Long, L As Long, x As Long
Set WbDestination = ThisWorkbook
L = WbDestination.Worksheets("Donnees").Range("A65536").End(xlUp).Row + 1
WbDestination.Worksheets("Donnees").Range("A6:N" & L).ClearContents
'Chemin = "X:\30_QUALITE\307_Gestion_de_service\AAAA-Main-Courante-Atelier\Recherches pour MC_commun\MC_commun"
Chemin = ThisWorkbook.Path 'si les 2 fichiers dans même dossier
'demande à l'utilisateur le numéro de semaine, semaine en cours par défaut
Semaine = InputBox("N° de la semaine", "SEMAINE", DatePart("ww", Date, vbMonday) - 1)
If Semaine = 0 Then Exit Sub
Fichier = "MC_Shootage.xlsm"
If FichierExiste(Chemin & "\" & Fichier) Then
'ouverture du fichier en lecture seule
Workbooks.Open Filename:=Chemin & "\" & Fichier, UpdateLinks:=0, ReadOnly:=True
Set WbSource = ActiveWorkbook
On Error Resume Next
x = Application.WorksheetFunction.CountIf(WbSource.Worksheets("Synthese").Range("B5:B1000"), "=" & Semaine)
If x > 0 Then
With WbSource.Worksheets("Synthese")
'Transfert des données
'exemple pour ajout de ligne(s)
For Each cel In .Range("B6:B1000")
If cel = Semaine Then
L = WbDestination.Worksheets("Donnees").Range("A65536").End(xlUp).Row + 1
.Range("A" & cel.Row & ":N" & cel.Row).Copy Destination:=WbDestination.Worksheets("Donnees").Range("A" & L)
End If
Next cel
End With
WbSource.Close SaveChanges:=False
Else
WbSource.Close SaveChanges:=False
End If
End If
End Sub
Function FichierExiste(NomFichier As String) As Boolean
FichierExiste = Dir(NomFichier) <> "" And NomFichier <> ""
End Function
Merci à tous ceux qui pourront m'aider!!