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
| Option Explicit
Private Sub CommandButton3_Click()
Unload Me
Dim Fichier As String, Chemin As String
Dim i As Integer, j As Integer, NbLigne As Integer, NumCl As Integer
Dim Trouver As Boolean
Dim Wb1 As Workbook, Wb2 As Workbook
Dim Ws1 As Worksheet, Ws2 As Worksheet
Application.ScreenUpdating = False
'Nouveau fichier issu de la mise à jour
Set Wb1 = Workbooks("Restitutions.xlsm")
Set Ws1 = Wb1.Worksheets("Support")
'Ancien fichier où se trouvent les commentaires
Fichier = TextBox1.Text
Chemin = ThisWorkbook.Path
Set Wb2 = Workbooks.Open(Chemin & "\" & Fichier)
Set Ws2 = Wb2.Worksheets("Support")
Ws1.Activate
'Nombre de lignes dans l'ancien fichier
NbLigne = Ws2.Cells(1, 1).CurrentRegion.Rows.Count
'On balaye toutes les lignes de l'ancien fichier
For i = 2 To NbLigne
'On copie le commentaire
Ws2.Cells(i, 16).Copy
'On relève l'identifiant de la ligne où doit se trouver le commentaire
NumCl = Ws2.Cells(i, 1)
Trouver = True
j = 2
'Si le commentaire existe
If IsEmpty(Ws2.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 Ws1.Cells(j, 1).Value = NumCl Then
Ws1.Paste Destination:=Ws1.Cells(j, 16)
Trouver = False
Else
j = j + 1
End If
Wend
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub |
Partager