Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9386 / 76732

←次へ　｜　前へ→


	【72908】Re:表を並べ替えたい

ウッシ - 12/10/5(金) 15:34 -


	引用なし

	パスワード

こんにちは

選択したセルのデータを消して並べ替えたデータ書き込みますのでバックアップをとっておいて下さい。

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

2 hits

▼

【72905】表を並べ替えたい ぶらっと 12/10/5(金) 13:11