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 copie()
Dim i As Integer
Dim j As Integer
Dim a As Integer
Dim LastRow As Long
Dim MyRange As Range
Application.ScreenUpdating = False
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For a = 2 To LastRow
For i = 3 To LastRow
If Cells(a, 1) = Cells(i, 1) Then
Cells(i, 3).Copy
For j = 4 To 15
If Cells(a, j) <> "" Then GoTo Line1 Else GoTo Line2
Line1:
Next j
Line2:
Cells(a, j).PasteSpecial Paste:=xlPasteValues
End If
Next i
Next a
Range("C3:C" & LastRow).Delete Shift:=xlToLeft
Set MyRange = ActiveSheet.Range("A1:O" & LastRow)
MyRange.RemoveDuplicates Columns:=1, Header:=xlYes
For O = 2 To LastRow Step 1
Cells(O, 13).FormulaR1C1 = "=CONCATENATE(RC[-10],"" "",RC[-9],"" "",RC[-8],"" "",RC[-7],"" "",RC[-6],"" "",RC[-5],"" "",RC[-4],"" "",RC[-3],"" "",RC[-2],"" "",RC[-1])"
Next O
Application.CutCopyMode = False
Range("M:M").Copy
Range("C:C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("D:M").Delete Shift:=xlToLeft
Application.ScreenUpdating = True
End Sub |
Partager