Bonjour à tous,
J'ai un petit soucis avec mon programme vba:
Je veux que mon pgm copie et colle des infos de 4 fichiers différents situer dans un dossier commun "MC_Commun".
Il doit ouvrir les fichiers, copier les infos de l'onglet "Synthese" de chacun d'eux et les coller dans l'onglet "Donnees" du fichier "MC_Commun" et se refermer.
Le soucis c'est que le pgm ouvre et ferme bien mes fichiers mais, ne me colle rien dans l'onglet "Donnees"...
Quelqu'un aurait une idée de ou est mon erreur?
Voici le pgm:
Merci pour votre aide
J'ai un petit soucis avec mon programme vba:
Je veux que mon pgm copie et colle des infos de 4 fichiers différents situer dans un dossier commun "MC_Commun".
Il doit ouvrir les fichiers, copier les infos de l'onglet "Synthese" de chacun d'eux et les coller dans l'onglet "Donnees" du fichier "MC_Commun" et se refermer.
Le soucis c'est que le pgm ouvre et ferme bien mes fichiers mais, ne me colle rien dans l'onglet "Donnees"...
Quelqu'un aurait une idée de ou est mon erreur?
Voici le pgm:
Code:
Option Explicit
Sub Dechet_Finition_Hebdo()
'Identification des chemins et des fichiers
Dim Chemin As String, WbDestination As Workbook, WbSource As Workbook
Dim Fichier(1 To 4) As String
Dim i As Integer
Dim cel As Range
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 = 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(1) = "MC_Shootage.xlsm"
Fichier(2) = "MC_Plastique.xlsm"
Fichier(3) = "MC_Finition.xlsm"
Fichier(4) = "MC_Expédition.xlsm"
For i = 1 To 4
If FichierExiste(Chemin & "\" & Fichier(i)) Then
'ouverture du fichier en lecture seule
Workbooks.Open Filename:=Chemin & "\" & Fichier(i), 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
With WbDestination.Worksheets("Donnees")
L = .Range("A" & .Row.Count).End(xlUp).Row + 1
.Range("A" & cel.Row & ":N" & cel.Row).Copy Destination:=WbDestination.Worksheets("Donnees").Range("A" & L)
End With
End If
Next cel
End With
End If
WbSource.Close SaveChanges:=False
End If
Next i
End Sub
Function FichierExiste(NomFichier As String) As Boolean
FichierExiste = Dir(NomFichier) <> "" And NomFichier <> ""
End FunctionMerci pour votre aide