(VBAにて)列のセルの結合について

質問

VBAを使って列の結合を行うとしています。
内容は
・A3とA4を結合～A59とA60を結合(60まで)
　という具合に、セル2つで一つの組み合わせです。
・これが列単位にA列～Y列まで同じように行おうとしています。
・一つ一つマクロで記述するとえらい手間がかかるので
　簡略するマクロ文は無いでしょうか？
・また、この作業はsheet3で行おうとしています。
　内容はsheet1に書かれていまして、
　(A4～Y4までが1レコードでA20～Y20まであります。)
　マクロで普通にsheet3にコピーをすると1レコード目の後に
　2レコード目が飛んで3レコード目が次にきてしまいます。
・これはどうすればよいでしょうか？

素人であまりよく分かりません
ご教授宜しくお願いします。

回答No.2

qualheart · ベストアンサー

Sub Macro1()

name1 = Worksheets(1).Name
name3 = Worksheets(3).Name
Worksheets(3).Activate
n = 4
For r = 3 To 59 Step 2
For c = 1 To 25
Worksheets(name3).Range(Cells(r, c), Cells(r + 1, c)).Merge
Worksheets(name3).Cells(r, c).Value = Worksheets(name1).Cells(n, c)
Next
n = n + 1
Next

End Sub

ですね。

お礼

返信ありがとうございました。
参考にさせて頂きました。
感謝しております。

回答No.3

imogasi

質問の表現をはっきりさせること。
私なら下記にする。
ーー
●Sheet1-->Sheet3へコピー、Sheet3でセル結合する。
言いたいことはSheet1からSheet3へデータを写すということであって
、コピー操作ではないのでは？紛らわしい。
●範囲はA3:Y60（＞A20～Y20まであります、と矛盾しない？）
●セル結合は、３行目と４行目、５と６・・のようにおこなう。
●A4とA5には、それぞれデータが入っているのか？
文字列は結合もできるが、数字セルはどうするのか？
あるいはSheet1の結合前の１行データを、セル結合後のSheet3の行に入れていくのか。
●行数を２倍にするの。普通には意味がないと思うが？行幅を広げればすむのでは？
こういうのはC列８行ぐらいで質問して、回答を質問者側でY列、６０行？まで広げればよい。
ーー
補足要求の返事もない場合が多いので、独断でやってみる。
例データ
Sheet1　A3:C11
a 12 34
b 23 123
c 34 45
d 45 678
e 12 432
f 2 345
g 4 112
h 7 334
コード
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")
'---
For j = 1 To 3 'C列までの例
For i = 3 To 8 * 2 + 2 Step 2 '8行の例
sh2.Range(sh2.Cells(i, j), sh2.Cells(i + 1, j)).MergeCells = True
k = Int((i - 1) / 2) + 2
sh2.Cells(i, j) = sh1.Cells(k, j)
Next i
Next j
End Sub
ーー
結果
Sheet3　A3:１８
a 12 34

b 23 123

c 34 45

d 45 678

e 12 432

f 2 345

g 4 112

h 7 334

ーー
＞素人であまりよく・・
質問文章の課題の説明が、あいまいと思った。VBAが判ってくると
明確に表現できるようになるもの。
マクロの記録で済むものとは随分考え方が違っているので、質問者には、荷が重いと思う。

お礼

返信ありがとうございました。
皆さんのを参考に何とか出来ました。
ありがとうございました。

回答No.1

n-jun

Sub　Test()
　Dim　i　As　Long
　Dim　j　As　Long
　Application.ScreenUpdating　=　False
　With　Worksheets("Sheet3")
　　　　　　For　i　=　1　To　25
　　　　　　　　　　For　j　=　3　To　59　Step　2
　　　　　　　　　　　　　　.Range(.Cells(j,　i),　.Cells(j　+　1,　i)).Merge
　　　　　　　　　　Next
　　　　　　Next
　　i　=　3
　　　　　　For　j　=　4　To　20
　　　　　　　　　　.Cells(i,　1).Resize(,　25).Value　=　_
　　　　　　　　　　Worksheets("Sheet1").Range("A"　&　j).Resize(,　25).Value
　　　　　　　　　　i　=　i　+　2
　　　　　　Next
　End　With
　Application.ScreenUpdating　=　True
End　Sub
こんな感じの事でしょうか？
ファイルをコピーしてから試してみて下さい。

お礼

返信ありがとうございました。
非常に参考になりました。
感謝しております。