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
| Sub traitement_01()
Dim c As Range
Dim firstAddress As String
Dim firstlign As Integer
Dim mavar As String
Dim Rg_Ligne As Range, Rg_Total As Range
Dim tablo(2000)
Dim num As Boolean
'Dim test
For i = 2 To 2000
'test = num
Set Rg_Total = ActiveSheet.Range("A2:G2")
With Worksheets("Feuil1").Range("G:G")
mavar = Range("G" & i)
Set c = .Find(mavar, LookIn:=xlValues, Lookat:=xlPart) '
If Not c Is Nothing Then
firstAddress = c.Address
firstlign = c.Row
Do
If mavar = WorksheetFunction.ImAbs(c.Value) Then
If c.Row <> firstlign Then
tablo(c.Row) = c.Row
num = True
End If
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
If num = True Then tablo(firstlign) = firstlign ' : Range("G" & firstlign).Clear
End With
num = False
Next i
For x = 2 To 2000
If tablo(x) <> "" Then
Set Rg_Ligne = ActiveSheet.Range("A" & tablo(x) & ":G" & tablo(x))
Set Rg_Total = Application.Union(Rg_Total, Rg_Ligne)
End If
Next x
Rg_Total.Copy Sheets("Feuil2").Range("a1")
Rg_Total.EntireRow.Delete
End Sub |
Partager