1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
| Option Explicit
Sub test()
Dim myAreas As Areas, myArea As Range, i As Long, n As Long
Application.ScreenUpdating = False
Set myAreas = Sheets(1).Columns(2).SpecialCells(2).Areas
n = 1
For Each myArea In myAreas
For i = 1 To myArea.Rows.Count Step 2
If i = 1 Then
Sheets(2).Cells(n, 1).Value = myArea.Cells(1)(0, 0).Value
End If
myArea.Cells(i).Resize(2).Copy
Sheets(2).Cells(n, 2).PasteSpecial Transpose:=True
n = n + 1
Next
n = n + 1
Next
Set myAreas = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub |
Partager