『マクロの高速で列の並べ替え』（NK）
今回もよろしくお願いします
列の並べ替えをしたくて下の自動記録でとったマクロをしました。
Sub Macro4()
'
' Macro4 Macro
'
Application.ScreenUpdating = False
Sheets.Add After:=ActiveSheet'--------Sheet2を作成
Sheets("Sheet1").Select'--------Sheet1へ移動
Columns("HXW:HXX").Select'--------Sheet1の最終列から左隣の2列分をセットで選択
Range("HXW4").Activate
Application.CutCopyMode = False
Selection.Copy'--------その2列をコピーする
Sheets("Sheet2").Select'--------Sheet2に移動
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A1").Select'--------Sheet2のA列を選択して貼付け
Columns("HXU:HXV").Select'--------Sheet1の更に左隣の2列を選択
Range("HXU4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("C1").Select'--------今度は次の2列に貼付け
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("HXS:HXT").Select'--------以降同じように繰り返す
Range("HXS4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("E1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("HXQ:HXR").Select
Range("HXQ4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("G1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("HXO:HXP").Select
Range("HXO4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("I1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("HXM:HXN").Select
Range("HXM4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("K1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("HXK:HXL").Select
Range("HXK4").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("M1").Select
ActiveSheet.Paste
Cells.Select
Application.CutCopyMode = False
'最初から列幅、行幅ともいっぺんにコピペできれば下の2行は不要
Selection.ColumnWidth = 40'--------Sheet1の列幅を再現
Selection.RowHeight = 11.25'--------Sheet1の行幅を再現
Application.ScreenUpdating = True
End Sub
Sheet1の最終列から左隣の2列分を、
Sheet2のA:B列に貼り付けます。
以降同じように隣り合わせに繰り返していきます。
なのでSheet1のA:B列は、Sheet2の最終列に入れ変わります。
Sheet2の作業列が不要でSheet1上のみで可能といういうことであれば、
結果が同じならば問いませんが出来るだけ早い方がいいです(何千列を使用していますもので)
宜しくお願いいたします。
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
> Sheet1の最終列から左隣の2列分を、 > Sheet2のA:B列に貼り付けます。 > 以降同じように隣り合わせに繰り返していきます。 > なのでSheet1のA:B列は、Sheet2の最終列に入れ変わります。 > Sheet2の作業列が不要でSheet1上のみで可能といういうことであれば、 > 結果が同じならば問いませんが出来るだけ早い方がいいです(何千列を使用していますもので) > 宜しくお願いいたします。
上記の記述は下のように解釈しました。
(1)最終的な目的は、
・Sheet1の列を入れ替えたい。
・その際、隣り合う二つの列はひとつのグループとして扱う。
・具体的イメージ
A列 B C D ・・・ HXU HXV HXW HXX
HXW列へ HXXへ HXU HXVへ ・・・ C列へ D列へ A列へ B列へ
(2)そこで、Sheet2というダミーシートを作り、そこににいったんコピーしたうえで、
それを再度Sheet1に書き戻すことを考えた。
(3)とりあえず、マクロ記録で、7グループ(14列）について、Sheet1からSheet2に転記してみた。
あと、どのように進めたらよいか、この調子では数千もある列を書き連ねるわけにもいかない。
といったことですか？
■
前提の確認ですが、
(質問1)対象となるセルたちは、データだけなんですか？
(質問2)数式があるとき、他の列を参照した数式があれば、単にコピーだと正しい計算にならない気がします。
その点はどうですか？
まずは、出発点を明確にしてください。 そうすれば色々なアプローチが可能かもしれません。
例えば、列単位にソートをする方法がとれるかもしれません。 最初の行に、ダミー行を追加し、 6055 6056 6053 6054 ・・・ 3 4 1 2 といった数列を書き込んでおき、それを基準に「列単位」の方向で、 追加行を基準として昇順ソートすると、並び変わるはずです。
■ なお、提示されたマクロ記録そのもののようなコードは普通使いません。 記述が細かすぎて理解しにくいです。 また、SelectやActiveといったものは出来るだけ使わないようにしてください。 以前のスレッドでも指摘があったかと思います。 少し勉強すれば、コピー周りの作業に関するコードは簡単に見つかります。
例えば、繰り返し構文を使えば、
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
j = 1
For k = Columns("HXW").Column To 1 Step -2
ws1.Columns(k).Resize(, 2).Copy ws2.Cells(1, j)
j = j + 2
Next
こんな風に書けます。
参考にしてください。
（xyz） 2026/11/10(火) 06:51:09
[解釈及び前提の確認]
解釈はそれでOKです。
二つの列はグループとして1・2・3行目は結合しております。
前提はSheet1は普段から作業列としておりますので元々計算式やら条件式書式も含んでおります。
プリントアウトする時にすべての全セルにおいて値のみの書き出し用データのみになります。
[例えば、列単位にソートをする方法がとれるかもしれません。]
確かに考えて見たらなんかこれで可能そうです。あとでやってみたいと思います。
これよりしばし朝ごはんを食ってきます。
（NK） 2026/11/10(火) 07:51:58
■１
＞結果が同じならば問いませんが出来るだけ早い方がいいです
コピー＆ペーストは何度も行うと、それなりに時間がかかります。
コードをざっと見ると列全体を対象にしていますが、みっちりとデータが詰まっているのでなければ、提案のあったように作業行を設けてソートするようにしてみるとよいのかなとおもいます。
■２
また、何らかの理由で並び替えはできないということであれば、一旦配列に値を格納して一気に出力するといったアプローチも有効かもしれません。
データ次第ですが、検討してみてはどうでしょうか。
■３
↓は全行全列という理解でよいですか？
'最初から列幅、行幅ともいっぺんにコピペできれば下の2行は不要
Selection.ColumnWidth = 40'--------Sheet1の列幅を再現
Selection.RowHeight = 11.25'--------Sheet1の行幅を再現
（もこな２） 2026/11/10(火) 08:05:29
（NK） 2026/11/10(火) 09:26:38
>どうしてもB・A列という風に順番を崩したくありませんでした。 意味がとれません。 グループを構成する2列の順序は変わらないように数列を指定するのです。
マクロで 結合解除 → 並び替え → 再度セル結合 という順番で実行すればよいのでは？ （xyz） 2026/11/10(火) 09:39:39
速度を求められていますが、まずはやってみて 実用に耐えられない位遅いのであれば、 それから高速化を検討してはどうでしょう
これを実行してみたら、どれくらい時間かかりますか？
Sub sample()
LastCol = Range("1:.1").Columns.Count
For i = LastCol + 1 To 4 Step -2
Range("A:B").Resize(, 2).Cut
Columns(i).Insert Shift:=xlToRight
Next
End Sub
（´・ω・`） 2026/11/10(火) 09:58:29
ちょっと修正しました。こちらで試して、時間を計ってください
Sub sample()
Application.Calculation = xlCalculationManual ' 追加 自動再計算→手動
LastCol = Range("1:.1").Columns.Count
For i = LastCol + 1 To 4 Step -2
Range("A:B").Resize(, 2).Cut
Columns(i).Insert Shift:=xlToRight
Next
Application.Calculation = xlCalculationAutomatic ' 自動再計算
End Sub
（´・ω・`） 2026/11/10(火) 10:21:17
ダミーデータ作ってやってみました だめですね。 時間かかりすぎでした 別案を考えます （´・ω・`） 2026/11/10(火) 10:50:58
> Columns("HXW:HXX").Select'--------Sheet1の最終列から左隣の2列分をセットで選択
> Range("HXW4").Activate
> Application.CutCopyMode = False
> Selection.Copy'--------その2列をコピーする
> Sheets("Sheet2").Select'--------Sheet2に移動
> ActiveSheet.Paste
これだとSheet2のアクティブセルの位置で貼り付け先の位置が 変わってしまうような気がするのだけれど、記憶違いだろうか？
>時間かかりすぎでした
コピペ等は時間かかりますよね、ただスタックオーバーフローが少し気になる （記憶違い？） 2026/11/10(火) 11:01:02
xyzさんの SORT案が爆速ですね
Sub test()
t = Timer
Range("1:.1").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
With Range("2:.2").Offset(-1)
.Formula = "=QUOTIENT(COLUMN()+1,2)"
.Value = .Value
End With
With Range("A1").CurrentRegion
.Parent.Sort.SortFields.Clear
.Parent.Sort.SortFields.Add2 Key:=.Rows(1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Parent.Sort.SetRange .Cells
With .Parent.Sort
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
.Rows(1).Delete shift:=xlUp
End With
Debug.Print Timer - t
End Sub
（´・ω・`） 2026/11/10(火) 13:47:38
（もこな２)さま いつもお気に留め戴きありがとうございます。
■２の一旦配列に値を格納の方法は、この際は不可とします。
■３その通りです。
（´・ω・`)さま
3案いずれもRange("1:.1")の行でデバッグがかって先に進みません。
何故なんでしょうか。
※オプションにシートを右から左へ表示するという項目がありますが無駄でした。
（´・ω・`)さまの修正案が通れば脈ありかと思われますがいかがなものでしょうか。
（NK） 2026/11/10(火) 16:44:38
>Range("1:.1")の行でデバッグ
1行目にデータがないのでは？
>マクロで 結合解除すると6055行により途端にメモリ不足
どんなコードなんですか？
Sub test()
t = Timer
Application.DisplayAlerts = False
ColCount = Range("A1").CurrentRegion.Columns.Count
Rows(1).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
With Range("A1").Resize(, ColCount)
.Formula = "=QUOTIENT(COLUMN()+1,2)"
.Value = .Value
End With
Cells.UnMerge
With Range("A1").CurrentRegion
.Parent.Sort.SortFields.Clear
.Parent.Sort.SortFields.Add2 Key:=.Rows(1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Parent.Sort.SetRange .Cells
With .Parent.Sort
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
.Rows(1).Delete shift:=xlUp
End With
Range("A1:B1").Merge
Range("A2:B2").Merge
Range("A3:B3").Merge
Range("A1:B3").Copy
Range("C1").Resize(3, ColCount - 2).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = True
Debug.Print Timer - t
End Sub （´・ω・`） 2026/11/10(火) 17:00:34
マクロで 結合解除すると6055行により途端にメモリ不足」 自動記録で取ったところそうなりました。これはマクロの記述が凄まじかったです。
それから気になった点が一つ、ウィンドウ枠の固定行が1行ズレました。
当初4行目と5行目の間にあるべきところ5行目と6行目の間になっていました。
これは率直に言ってこちらですぐ修正できますがマクロに組み込んでいただけますでしょうか。
この度の御回答誠にありがとうございました。
（NK） 2026/11/10(火) 18:51:34
自分でやって （´・ω・`） 2026/11/10(火) 20:59:01
素晴らしいコードをありがとうございました。
時代年表風に編集作業においてブックを時代が若い降順にして毎月AB列を2列づつ挿入して足して行くので左側にあった方が何かと便利でやり易いし大幅に右側にスクロールしないで済みますが、いざプリントアウト時は時代を昇順に並べ替えたいということでお手数をお掛けしました。
誠にお騒がせしまして申し訳ございませんでした。
（NK） 2026/11/11(水) 00:11:57
>「コードは安全なはず」とお墨付きを得られた感じです 書いて無いことを勝手に読み取られては困ります このような掲示板では、コードの保証なんてありません。 自分で読んで理解して大丈夫そうだとおもったら、自己責任で使ってください。
で、
.Rows(1).Delete shift:=xlUp
End With
を
End With
Rows(1).Delete shift:=xlUp
にしてください
原因は、作業列の追加と削除で対象が違っていたことでした （´・ω・`） 2026/11/11(水) 08:30:23
（NK） 2026/11/11(水) 13:14:47
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.