1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
| Option Explicit
Sub Macro1()
'Identification des chemins et des fichiers
Dim Chemin As String, WbDestination As Workbook, WbSource As Workbook
Dim Fichier(1 To 1) As String
Dim i As Integer
Dim cel As Range
Dim LaDate As String, 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 la date du jour, date en cours par défaut
LaDate = Format(Now, "dd\/MM\/yyyy")
Do
LaDate = InputBox("Entrez une date", "Date", LaDate)
Loop Until IsDate(LaDate)
If LaDate = "" Then Exit Sub
Fichier(1) = "MC_Shootage.xlsm"
'Fichier(2) = "MC_Finition.xlsm"
'Fichier(3) = "MC_Expédition.xlsm"
'Fichier(4) = "MC_TS.xlsm"
'Fichier(5) = "MC_Luxe.xlsm"
'Fichier(6) = "MC_Contrôle_Composants_CARTIER.xlsm"
'Fichier(7) = "MC_Plastique.xlsm"
'Fichier(8) = "MC_Metal.xlsm"
'Fichier(9) = "MC_Witech.xlsm"
For i = 1 To 1
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("A6:A10000"), "=" & LaDate)
If x > 0 Then
With WbSource.Worksheets("Synthese")
'Transfert des données
'exemple pour ajout de ligne(s)
For Each cel In .Range("A6:A10000")
If cel = LaDate Then
With WbDestination.Worksheets("Donnees")
L = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
Application.ScreenUpdating = False
.Range("A" & cel.Row & ":N" & cel.Row).Copy
WbDestination.Worksheets("Donnees").Range("A" & L).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next cel
End With
End If
Application.ScreenUpdating = True
WbSource.Close SaveChanges:=False
End If
Next i
End Sub
Function FichierExiste(NomFichier As String) As Boolean
FichierExiste = Dir(NomFichier) <> "" And NomFichier <> ""
End Function |
