ExcelVBA 2列ずつ取り出し1列に

質問

お世話になります。

Excelで、あるデータを整理せねばならないのですが、
A列にID番号、B列に人名、
C列にID番号、D列に人名、というようなデータがあり
このような状態です。

0001 山田花子　　　　　　0002　田中太郎

これをA列に縦1列、つまりこのような状態にしたいのです。
0001 　山田花子
0002　田中太郎

量が多くて、手で処理できないので、VBAでやりたいのですが、
この場合どのようなコードになるでしょうか。

教えていただければ幸いです。

回答No.4

tom04

こんにちは！
A列1列だけに表示したい！というコトですよね？

一例です。
データは1行目からあるとします。
画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 2
Range(Cells(1, j + 2), Cells(Cells(Rows.Count, j + 2).End(xlUp).Row, j + 3)).Cut _
Cells(Rows.Count, 1).End(xlUp).Offset(1)
'データが2行目以降にある場合、Cells(1, j + 2)　の「1」を「2」に！
Next j

i = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(1, 3), Cells(i, 3)).Formula = "=TEXT(A1,""0000"")&"" ""&B1"
Columns(3).Copy
Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Columns("B:C").Delete
Columns(1).AutoFit
Application.ScreenUpdating = True
End Sub 'この行まで

※　一旦マクロを実行すると元に戻せませんので、別Sheetで試してみてください。m(_ _)m

お礼

ありがとうございます！

本当にお手数かけていただいて・・・感謝します！

回答No.3

mu2011

>量が多くて、手で処理できない
　⇒ＶＢＡや関数より手動の方が手っとり早いと思いますよ。
（１）Ｃ：Ｄ列のデータ範囲を選択してコピー→Ａ列データの最終セル＋１に貼り付け
　　　コピー範囲は、名前ボックスにセル範囲（仮にC1:D2000）入力、Enter押下で一気に選択できます。
　　　Ａ列の最終はA1を選択→Ctrl＋↓キー押下でデータ終端セルにジャンプするので＋１します。

（２）Ａ１を選択→並び替え、昇順→Ｃ：Ｄ列削除

お礼

ありがとうございます。

それも考えたのですが、実は余計なデータがいっぱい入っているので、なかなか一括選択も難しく・・・。何万行もあったりして・・・。

お答えをいただいたらそれを土台に考えたいなって思ってました。

でも参考になる事がたくさんありました。

回答No.2

KURUMITO

VBAというよりも関数を使って行うことが計算の速度も速く一旦設定すれば何の操作をすることもなく即座に表が対応できるなどマクロにはない良さが発揮されますね。
例えばデータがシート１のA１およびC1セルにはIDの文字が、B１およびD1セルには人名の文字が有り、各データが２行から下方に入力されているとします。
結果を表示したいセルを選んで（同じシート内でもよし、別のシート内でも良し）次の式を入力し右横の列までドラックコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>(COUNTA(Sheet1!$B:$B)+COUNTA(Sheet1!$D:$D)-2),"",IF(MOD(ROW(A1),2)=1,INDEX(Sheet1!$A:$B,ROUNDUP((ROW(A1)+2)/2,0),COLUMN(A1)),INDEX(Sheet1!$C:$D,ROUNDUP((ROW(A1)+2)/2,0),COLUMN(A1))))

お礼

あ、なるほど・・・。

関数を使うんですね。気づきませんでした。
視野が広がります。

ありがとうございました！

回答No.1

K Kazz（@JazzCorp）

Ａ列に追加しちゃいました、、、
xHeadsにヘッダの行数指定してください。

Option Explicit
Sub NumAmyDahbuts()
Const xHeads = 1
Dim kk As Long
Dim nn As Long
Dim mm As Long
Dim xSheet As Worksheet
Dim xLast As Long
Dim zLast As Long
Dim zLast_Col As Long
Dim xAnswer As Integer
zLast_Col = Cells(1, Columns.Count).End(xlToLeft).Column
zLast = Cells(Rows.Count, "A").End(xlUp).Row
nn = zLast + 1
For kk = 3 To zLast_Col Step 2
xLast = Cells(Rows.Count, kk).End(xlUp).Row
For mm = xHeads + 1 To xLast
If (Cells(mm, kk) <> Empty) Then
Cells(nn, "A").Resize(1, 2).Value = Cells(mm, kk).Resize(1, 2).Value
nn = nn + 1
End If
Next mm
Next kk
End Sub