エクセルVBA（rangeでの複数範囲指定方法）

質問

いつも有難うございます。
タイトルの件でご教示いただきたく、お願いいたします。

やりたいことは、複数のセル結合を一括でおこないたい、というものです。

具体的には【A列をn行目まで、2行ずつセル結合する】方法です。

例えば、20行目まで2行ずつ結合する、と決まっていれば次のような記述が可能です。
（例１）
Range( _
"A1:A2,A3:A4,A5:A6,A7:A8,A9:A10,A11:A12,A13:A14,A15:A16,A17:A18,A19:A20"). _
MergeCells = True

これを「n行目」までとするため、次のような記述を考えました。
（例２）
　　Dim i As Integer
　　Dim n As Integer

Range("A65536").End(xlUp).Select
n = ActiveCell.Row + 1

For i = 1 To n Step 2
Range(Cells(i, 1), Cells(i + 1, 1)).MergeCells = True
Next

こちらの　For　～　Next　内の構文についてです。
この構文ですと、一つずつ選択→結合をしていくので、相応の時間がかかってしまうため、
例１の構文のように、先に範囲を指定して一括で結合する方法を調べたのですが見つからず
質問させていただきました。

（やりたい構文）
For i = 1 To n Step 2
　　※ = （A1:A2,A3:A4,・・・An-1:An）
Next
　　Range(※).MergeCells = True

このような方法はありますでしょうか。
ご教示のほど、宜しくお願いいたします。

回答No.1

satoron666 · ベストアンサー

http://veaba.keemoosoft.com/2013/02/494/

これとか参考にどうでしょうか？

お礼

皆様、いろいろとお知恵をくださり有難うございました。
それぞれ試してみたところ、甲乙付けがたかったのですが、
こちらが一番しっくりきたのとリンク先のページが
その他の情報の参考にもなるので、ベストアンサーに
選ばせていただきました。
今後とも宜しくお願いいたします。

回答No.4

tom04

こんにちは！
一例です。

A列の65536行目までを2行ずつ結合するとして・・・
倍々でコピーしていってはどうでしょうか？
まずA1・A2セルを結合　→　A3セルにコピー＆ペースト　→　A1～A4セルをA5セルに
A1～A8セルをA9セルに　→　A1～A13をA17セルに・・・
といった感じです。
最初はあまり速くない感じですがコピー＆ペーストの範囲がだんだん広くなっていきます。
最終的にはこれを15回繰り返せば65536行まで達すると思います。

Sub Sample1()
Dim cnt As Long
Range("A1:A2").Merge
Do Until cnt = 15
cnt = cnt + 1
Range(Cells(1, "A"), Cells(2 ^ cnt, "A")).Copy Cells(2 ^ cnt + 1, "A")
Loop
MsgBox "処理完了"
End Sub

尚、お示しのコードはA65536セルから上に向かって最終データ行を取得し、結合したいものと思われますが、
すべて同じデータであれば問題ないかもしれませんけど、データが違う場合は結合できないと思いますので
インプットボックスに結合したい最終行（かならず偶数行）を入力し
A1～入力したセルまでを二つずつ結合させるコードも載せてみます。
（単にオートフィルでの処理です）

Sub Sample2()
Dim lastRow As Long
lastRow = InputBox("結合したい最終行を偶数で入力")
Range("A1:A2").Merge
Range("A1").Select
Selection.AutoFill Destination:=Range(Cells(1, "A"), Cells(lastRow, "A")), Type:=xlFillDefault
End Sub

こんな感じではどうでしょうか？m（_ _）m

回答No.3

noname#203218

for ～lnext、Do～Loop両方やってみました。
１００００行処理で両方共に約１秒の処理時間でした。
B１セルに処理時間表示するようにしてあります。

確認後はタイマーの不要部分は削除下さい。

処理速度はor ～lnextよりDo～Loopの方が早いとネットで出てましたが、演算でないのであまり変わらないようです。
selectやactive、copy等は処理速度が遅くなるはずですので、使用は出来るだけ避けたほうが良いようです。

Application.ScreenUpdating = Falseで画面更新を中断させました。これで私のPCで約0.5秒早く処理出来ました。

ご参考まで

Sub sample1()
Dim i, n As Long
Dim dblStart As Double '開始時刻取得エリア
Dim dblEnd As Double '終了時刻取得エリア
Dim lngCnt As Long 'カウンタ
Dim dblTime As Double '所要時間取得エリア

dblStart = Timer

'最終行が奇数行の場合は１を足し偶数行にする。
n = Cells(Rows.Count, 1).End(xlUp).Row
If n Mod 2 = 1 Then n = n + 1

Application.ScreenUpdating = False

For i = 1 To n Step 2

Range(Cells(i, 1), Cells(i + 1, 1)).MergeCells = True

Next

'終了時刻を取得する
dblEnd = Timer

'所要時間を計算する
dblTime = dblEnd - dblStart

' 所要時間を表示します。
Cells(1, 2) = "所要時間は" & Format$(Int(dblTime * 10 ^ 4 + 0.5) / 10 ^ 4) & "秒だよ。"

Application.ScreenUpdating = True

End Sub

Sub sample2()
Dim i, n As Long
Dim dblStart As Double '開始時刻取得エリア
Dim dblEnd As Double '終了時刻取得エリア
Dim lngCnt As Long 'カウンタ
Dim dblTime As Double '所要時間取得エリア

dblStart = Timer

n = Cells(Rows.Count, 1).End(xlUp).Row
If n Mod 2 = 1 Then n = n + 1

i = 1

Application.ScreenUpdating = False

Do While i < n

Range(Cells(i, 1), Cells(i + 1, 1)).MergeCells = True
i = i + 2

Loop

'終了時刻を取得する
dblEnd = Timer

'所要時間を計算する
dblTime = dblEnd - dblStart

' 所要時間を表示します。
Cells(1, 2) = "所要時間は" & Format$(Int(dblTime * 10 ^ 4 + 0.5) / 10 ^ 4) & "秒だよ。"

Application.ScreenUpdating = True
End Sub

回答No.2

chie65535

Range("A65536").End(xlUp).Select
n = Int((ActiveCell.Row + 1) / 2) * 2
Range("a1:a2").Select
Selection.Merge
Selection.Copy
Range(Cells(3, 1), Cells(n, 1)).Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

「結合は書式だから、書式のコピーをすれば良い」ってのに気が付けるかどうか。

あと「２行分をコピーしているから、コピー先のセルの範囲指定は必ず２の倍数の行数にしないといけない」ので、nの計算にちょっと調整が入ってます。

あと「セルのコピー」なので、数万行あれば「それなりの時間」がかかります。