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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
| Private Sub CommandButton3_Click() 'Bouton Commentaires
Dim Fichier As String, Chemin As String
Dim WbCible As Workbook, WbSource As Workbook
Dim WsCible As Worksheet, WsSource As Worksheet
'Nouveau fichier issu de la mise à jour
Set WbCible = Workbooks("Restitutions.xls")
'Ancien fichier où se trouvent les commentaires
Fichier = TextBox1.Text
Chemin = ThisWorkbook.Path
'Ouverture Ancien fichier
Set WbSource = Workbooks.Open(Chemin & "\" & Fichier)
'Mise à jour des commentaires de la feuille "Support"
Set WsCible = WbCible.Worksheets("Support")
Set WsSource = WbSource.Worksheets("Support")
CommentSupport WsCible, WsSource
'Mise à jour des commentaires de la feuille "Closed"
Set WsCible = WbCible.Worksheets("Closed")
Set WsSource = WbSource.Worksheets("Closed")
CommentClosed WsCible, WsSource
'Effacement
Set WsSource = Nothing
Set WbSource = Nothing
Set WsCible = Nothing
Set WbCible = Nothing
End Sub
Private Sub CommentSupport(WsCible, WsSource)
Dim i As Integer, j As Integer, NbLigne As Integer, NumCl As Integer
Dim Trouver As Boolean
Me.Hide
Application.ScreenUpdating = False
'Nombre de lignes dans l'ancien fichier
NbLigne = WsSource.Cells(1, 1).CurrentRegion.Rows.Count
'On balaye toutes les lignes de l'ancien fichier
For i = 2 To NbLigne
'On copie le commentaire
WsSource.Cells(i, 16).Copy
'On relève l'identifiant de la ligne où doit se trouver le commentaire
NumCl = WsSource.Cells(i, 1)
Trouver = True
j = 2
'Si le commentaire existe
If IsEmpty(WsSource.Cells(i, 16)) = False Then
'On balaye toutes les lignes du nouveau fichier afin de trouver le même identifiant
While Trouver And j < NbLigne + 1
'Si le même identifiant est trouvé, on copie le commentaire
If WsCible.Cells(j, 1).Value = NumCl Then
WsCible.Paste Destination:=WsCible.Cells(j, 16)
Trouver = False
Else
j = j + 1
End If
Wend
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Sub CommentClosed(WsCible, WsSource)
Dim i As Integer, j As Integer, NbLigne As Integer, NumC As Integer
Dim Trouver As Boolean
Application.ScreenUpdating = False
'Nombre de lignes dans l'ancien fichier
NbLigne = WsSource.Cells(1, 1).CurrentRegion.Rows.Count
'On balaye les 3 colonnes de commentaires de l'ancien fichier
For k = 18 To 20
'On balaye toutes les lignes de l'ancien fichier
For i = 2 To NbLigne
'On copie les commentaires
WsSource.Cells(i, k).Copy
'On relève l'identifiant de la ligne où doit se trouver les commentaires
NumC = WsSource.Cells(i, 1)
Trouver = True
j = 2
'Si le commentaire existe
Debug.Print WsSource.Cells(i, k)
If IsEmpty(WsSource.Cells(i, k)) = False Then
'On balaye toutes les lignes du nouveau fichier afin de trouver le même identifiant
While Trouver And j < NbLigne + 1
'Si le même identifiant est trouvé, on copie le commentaire
If WsCible.Cells(j, 1).Value = NumC Then
WsCible.Paste Destination:=WsCible.Cells(j, k)
Trouver = False
Else
j = j + 1
End If
Wend
End If
Next i
Next k
Unload Me
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub |
