数値データのコピーと移動をするVBAについて

質問

画像上部のようにデータがあるときに、各行について
列Aについては、列Bから数値が入力されている列数分コピーを行い、列Bより右側の列に入力されている数値を列Bに移動させたいのです。
（画像左下部を参考にしていただけるといいと思います）

※画像がみづらくて申し訳ありません。

詳しい事は分かりませんが、データの正規化というものでしょうか・・・？

これをVBAを用いて行えたらと思いまして詳しい方からのアドバイスを頂けましたら幸いだと思い書き込みしました。よろしくお願いします。

回答No.1

tom04 · ベストアンサー

こんばんは！
一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, j As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")

wS2.Range("A:B").ClearContents
Application.ScreenUpdating = False
For i = 1 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
j = wS1.Cells(i, Columns.Count).End(xlToLeft).Column
If j > 1 Then
wS1.Cells(i, 2).Resize(1, j - 1).Copy
wS2.Activate
wS2.Cells(Rows.Count, 2).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
wS2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(j - 1, 1) = wS1.Cells(i, 1)
End If
Next i
wS2.Rows(1).Delete
Application.ScreenUpdating = True
wS2.Cells(1, 1).Select
End Sub

※　B列以降、途中に空白セルはない！という前提です。

こんな感じではどうでしょうか？m(_ _)m

お礼

ご回答ありがとうございました。大変参考になりました。ベストアンサーにさせていただきます。また、この内容について分からないことがありましたら改めて質問をさせてください。よろしくお願いします。