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
| Sub Mettreajour()
'
' Mettreajour Macro
' Macro enregistrée le 13/09/2013 par Administrateur
'
Application.ScreenUpdating = False
Set orig = ThisWorkbook.Sheets("test2")
Set dest = ThisWorkbook.Sheets("PLANNING")
Dim i As Long
Dim c As Object
i = 2
NouvelleLigne = 6
While dest.Range("B" & NouvelleLigne).Value <> 0
NouvelleLigne = NouvelleLigne + 1
Wend
While orig.Range("B" & i).Value <> 0
What = orig.Range("B" & i).Value
Set c = dest.Range("B1:B" & NouvelleLigne).Find(What:=What, LookIn:=xlFormulas, LookAt:=xlWhole, SearchFormat:=False, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If c Is Nothing Then
dest.Activate
dest.Range("A" & NouvelleLigne).Select
orig.Range("A" & i & ":H" & i).Copy dest.Range("A" & NouvelleLigne)
Application.CutCopyMode = False
NouvelleLigne = NouvelleLigne + 1
Else
AncienneLigne = c.Row
orig.Range("A" & i & ":H" & i).Copy dest.Range("A" & AncienneLigne)
End If
i = i + 1
Wend
'vérification qu'il n'y pas de valeur dans planning présente et non dans teste2
i = 2
AncienneLigne = 6
While orig.Range("B" & i).Value <> 0
i = i + 1
Wend
While dest.Range("B" & AncienneLigne).Value <> 0
What = dest.Range("B" & AncienneLigne).Value
Set c = orig.Range("B1:B" & i).Find(What:=What, LookIn:=xlFormulas, LookAt:=xlWhole, SearchFormat:=False, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If c Is Nothing Then
dest.Rows(AncienneLigne).Select
dest.Rows(AncienneLigne).Delete Shift:=xlUp
Else
AncienneLigne = AncienneLigne + 1
End If
Wend
End Sub |
