エクセルマクロについて質問です。

質問

添付画像のようなマクロを教えていただきたいです。説明が下手ですがよろしくお願いします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.2

watabe007 · ベストアンサー

こんにちは、参考に

Sub Test()
　　Dim sh1 As Worksheet, sh2 As Worksheet
　　Dim c As Range, myR As Long

　　myR = 2
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　For Each c In sh1.Range("A2", sh1.Cells(Rows.Count, "A").End(xlUp))
　　　　sh2.Cells(myR, "A").Resize(, 2).Value = c.Resize(, 2).Value
　　　　If c.Offset(, 2).Value <> "" Then
　　　　　　myR = myR + 1
　　　　　　sh2.Cells(myR, "A").Value = "空白"
　　　　　　sh2.Cells(myR, "B").Value = c.Offset(, 2).Value
　　　　End If
　　　　myR = myR + 1
　　Next
　　Set sh1 = Nothing
　　Set sh2 = Nothing
End Sub

お礼

参考になりました。ありがとうございます。

回答No.1

misatoanna

Sheet1の１行目(A:C)が項目名、２～７行目にデータが入力済み。
Sheet2の１行目(A:B)が項目名、２行目以下にマクロで書き込む。
という前提です。

思いつきですが――

Sub Test()
　　Dim rng As Range, DT As String
　　Dim splt As Variant, r As Long
　　Sheets("Sheet1").Activate
　　For Each rng In Range("B2:C7")
　　　　If rng.Value = "" Then GoTo NXT
　　　　Select Case rng.Column
　　　　　　Case Is = 2
　　　　　　　　DT = DT & rng.Offset(0, -1).Value & " " & rng.Value & ","
　　　　　　Case Is = 3
　　　　　　　　DT = DT & Range("C1").Value & " " & rng.Value & ","
　　　　End Select
NXT: Next
　　splt = Split(Left(DT, Len(DT) - 1), ",")
　　With Sheets("Sheet2")
　　　　For r = 0 To UBound(splt)
　　　　　　.Cells(r + 2, 1).Value = Split(splt(r), " ")(0)
　　　　　　.Cells(r + 2, 2).Value = Split(splt(r), " ")(1)
　　　　Next
　　End With
End Sub

お礼

回答ありがとうございます。