Excelで列の操作の自動化をしたいです

質問

列、C列、E列、G列・・・の１行目にはタイトルが入力されており、
B列、D列、F列、H列・・・には不特定の文字列が入力されており、それぞれ行数も不特定です。

A列、C列、E列、G列・・・の１行目のタイトルはA列にまとめ、B列、D列、F列、H列・・・の文字列はB列にまとめたいです。

下の例の場合だと、C列の１行目のタイトルをB列の下端の左下にあたる(A7)に移動させ、
D列の２行目から入力された文字列を右となりの(B7)に移動させたいです。これの繰り返しをマクロで自動化したいです。

　　　　A列　　　　　B列　　　　　C列　　　　　D列
1　　　　あ　　　　　　 A　　　 　　　い　　　　　　
2　　　　　　　　　　 　 B　　　 　　　 　 　 　　　　a　　
3　　　　　　　　　　　 C　　　 　　　 　　 　 　　　b
4 　　　　　　　　 　 　 D　　　 　　　 　　　 　　　c
5　　　 　　　　　　　　 E　　　 　　　 　 　　　　　
6　　 　　　　　　　 　　 F　　　 　　　 　　　　　　

　　　　　　　　　　　　　↓

　　　　A列　　　　　B列　　　　　C列　　　　　D列
1　　　　あ　　　　　　 A　　　 　　　　　　　　　
2　　　　　　　　　　 　 B　　　 　　　 　 　 　　　　　　
3　　　　　　　　　　　 C　　　 　　　 　　 　 　　　
4 　　　　　　　　 　 　 D　　　 　　　 　　　 　　　
5　　　 　　　　　　　　 E　　　 　　　 　 　　　　　
6　　 　　　　　　　 　　 F　　　 　
7　　　　　　い　　　　 　a
8　　　　　　　　　　　　　b
9　　　　　　　　　　　　　c

よろしくお願いします。

回答No.3

Wendy02 · ベストアンサー

こんばんは。

>B列、D列、F列、H列・・・において文字列が入っていないブランク状態でも
>A列、C列、E列、G列・・・のタイトルを配置するにはどのようにしたらよろしいのでしょうか？

あくまでも、２列ごとのデータは、横並びにしていますから、何らかの条件を設けないと、タイトルは、消えてしまうと思います。ですから、タイトルを配置を残すためには、B列側は、１行を開けなくてはなりません。

'例：
'Option Explicit

Sub AligmentColumns()
　　Dim r As Range
　　Dim i As Integer
　　Dim j As Long
　　Dim Lc As Integer
　　Dim Lr As Long
　　Const MXR As Long = 65536 '最大行

　　With ActiveSheet
　　Lc = .UsedRange.Columns.Count '最後のデータの列
　　Lr = .UsedRange.Rows.Count '最後のデータの行

　　j = .Cells(MXR, 2).End(xlUp).Row + 1 'B列の行の最後尾

　　Application.ScreenUpdating = False
　　For i = 3 To Lc Step 2
　　　　If .Cells(1, i).Value <> "" Then
　　　　　　.Cells(1, i).Copy .Cells(j, 1)
　　　　End If
　　　　If .Cells(MXR, i + 1).End(xlUp).Value <> "" Then
　　　　　 .Range(.Cells(2, i + 1), .Cells(MXR, i + 1).End(xlUp)).Copy .Cells(j, 2)
　　　　　 j = .Cells(MXR, 2).End(xlUp).Row　'B列の行の最後尾
　　　　End If
　　　　j = j + 1　'消さないこと
　　Next i

　　End With
　　'移し終わったら消す場合は、下の行の行頭の" ' " を外す
　　'Range("C1").Resize(Lr, Lc - 2).ClearContents
　　Application.ScreenUpdating = True
End Sub

お礼

丁寧なご回答ありがとうございます。
おかげさまで成功しました。

回答No.2

zap35

＃０１です
　　LastR = .Range("B65536").End(xlUp).Row
の行の直後に
　　If .Range("A65536").End(xlUp).Row > LastR Then
　　　LastR = .Range("A65536").End(xlUp).Row
　　End If
を追加すればとりあえず動くでしょう。テストはしてませんが…

それ以外にも条件があるならマクロをいじってみてください。
丸投げばかりではマクロは覚えられませんよ。

お礼

丁寧なご回答有難うございます。
これからまたいろいろいじってみます。

回答No.1

zap35

少しごちゃごちゃしてしまいましたが、以下のマクロをALT＋F11でVBE画面を開き、左上のVBA Projectでシート名を右クリックし「挿入」→「標準モジュール」で表示される画面に貼り付けて下さい。マクロの実行はALT＋F8でマクロ一覧を開き、マクロ名を選択して「実行」ボタンです。

Sub Macro1()
Dim LastR As Long
Dim idxC, idxR, ptr As Integer
With ActiveSheet
　idxC = 3
　Do Until .Cells(1, idxC) = ""
　　LastR = .Range("B65536").End(xlUp).Row
　　.Cells(LastR + 1, "A") = .Cells(1, idxC) 'Title
　　ptr = 0
　　For idxR = 1 To .Cells(65536, idxC + 1).End(xlUp).Row
　　　If .Cells(idxR, idxC + 1) <> "" Then
　　　　ptr = ptr + 1
　　　　.Cells(LastR, "B").Offset(ptr, 0).Value = _
　　　　　　.Cells(idxR, idxC + 1).Value
　　　End If
　　Next idxR
　　idxC = idxC + 2
　Loop
End With
End Sub

お礼

ご回答ありがとうございます。
早速試させていただいたところ、成功いたしました。
B列、D列、F列、H列・・・において文字列が入っていないブランク状態でも
A列、C列、E列、G列・・・のタイトルを配置するにはどのようにしたらよろしいのでしょうか？
よろしくお願いします。