VBAでExcelの表の修正

質問

添付画像の様な表Aを表Bに修正しています。
これまで手作業(コピペで数日かかる)で行っていましたが、
VBAで自動的に処理できたらと考えてます。

Noは一意となり、件数はおよそ5000件程度。
上から処理したとして、Name列に名前が無くなったら終了。

この表Aを表Bの様に修正(新規作成でも可)するVBAの処理を教えてください。
私はVBAの勉強を始めたばかりなので解説もつけて頂けると助かります。
分かりにくい説明ですみません。

よろしくお願いします、どうかお知恵をお貸しください。

回答No.2

tom04

こんばんは！
一例です。

「表A」はSheet1にあり、画像通り3行目はタイトル行でデータは4行目以降にある。
「表B」はSheet2として3行目のタイトルはすでに入力済みだとします。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
j = ws.Cells(Rows.Count, 1).End(xlUp).Row
If j > 3 Then
ws.Rows(4 & ":" & j).ClearContents
End If
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(i, j) <> "" Then
With ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = Cells(i, 1)
.Offset(, 1) = Cells(i, j)
.Offset(, 2) = Cells(i, 2)
.Offset(, 3) = Cells(3, j)
End With
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub 'この行まで

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

回答No.1

keithin

シート１に表Ａを作る
シート２に表Ｂを作る
表Ａ、Ｂはどちらも実際には１行目に項目行を置き、２行目から実データを記入する

sub macro1()
　dim i as long

’シート２を準備する
　worksheets("Sheet2").cells.clearcontents
　worksheets("Sheet2").range("A1:D1") = array("name","no","alma mater","item")

’シート１のＡ列を１行ずつ巡回する
　for i = 2 to worksheets("Sheet1").range("A65536").end(xlup).row

’シート２のＡ，Ｃ，Ｄ列を作成する（単純に転記する）
　worksheets("Sheet2").range("A65536").end(xlup).offset(1).resize(5, 1).value = worksheets("Sheet1").cells(i, "A").value
　worksheets("Sheet2").range("C65536").end(xlup).offset(1).resize(5, 1).value = worksheets("Sheet1").cells(i, "B").value
　worksheets("Sheet2").range("D65536").end(xlup).offset(1).resize(5, 1).value = application.transpose(worksheets("Sheet1").range("C1:G1"))

’シート２のＢ列を作成する（形式を選んで貼り付けで行列を入れ替える）
　worksheets("Sheet1").cells(i, "C").resize(1, 5).copy
　worksheets("Sheet2").range("B65536").end(xlup).offset(1).pastespecial transpose:=true

　next i
end sub