| |
こんにちは
選択したセルのデータを消して並べ替えたデータ書き込みますのでバックアップをとっておいて下さい。
Sub test()
Dim s As Range
Dim i As Long
Dim j As Long
Dim ii As Long
Dim jj As Long
Dim r As Long
Dim c As Long
Dim d()
On Error Resume Next
Set s = Selection
If s Is Nothing Then Exit Sub
On Error Resume Next
With s
i = .Cells.Count
If .Rows.Count <> 1 Then Exit Sub
If .Row <> 1 Then Exit Sub
If i < 2 Then Exit Sub
With .Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With WorksheetFunction
j = .CountA(s.Cells(1, 1).EntireColumn)
ReDim d(1 To j * 2, 1 To .RoundUp(i / 2, 0))
End With
For jj = 1 To j
r = jj * 2 - 1
For ii = 1 To i Step 2
c = (ii + 1) / 2
d(r, c) = s(jj, ii).Formula
If ii + 1 < i Then
d(r + 1, c) = s(jj, ii + 1).Formula
End If
Next
Next
.EntireColumn.ClearContents
.Resize(UBound(d, 1), UBound(d, 2)).Value = d
With .Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End With
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
