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 |
