VBAのコードについての質問

質問

いつもお世話になっております。

以下の操作（添付ファイル）に対するVBAのコードを教えてください。

(1)シート1（添付ファイル左）：B列に新聞名、C列に対象記事数
(2)マクロを実行することにより、シート2（添付ファイル左）の表が作成される。

質問したい事は、A新聞の記事数が3、B新聞の記事数が2なので、シート2にA新聞の行が3行作成され、その下に、B新聞の行が2行・・・・記事数が0の場合は行は作成されない。
のような事をやいりたいのですが、コードが分かりません。

どなたかよろしくご教授ください。

回答No.2

tom04 · ベストアンサー

こんにちは！
すでに的確な回答は出ていますが、参考程度で・・・

標準モジュールです。

Sub Sample1()
Dim i As Long, lastRow As Long, cnt As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "B")).ClearContents
End If
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
cnt = 0
Do Until cnt = .Cells(i, "C")
cnt = cnt + 1
wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) = wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row - 1
wS.Cells(Rows.Count, "B").End(xlUp).Offset(1) = .Cells(i, "B")
Loop
Next i
End With
End Sub

こんな感じではどうでしょうか？m（_ _）m

お礼

ありがとうございます。

回答No.1

satoron666

少し適当ですが、

Option Explicit

Sub test()
Dim Sheet1_Row As Long
Dim Sheet2_Row As Long
Dim i, j As Long
Dim Newspaper As String

Sheet1_Row = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
Sheet2_Row = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Sheet1_Row
j = ThisWorkbook.Worksheets("Sheet1").Range("C" & i)
If j <> 0 Then
Newspaper = ThisWorkbook.Worksheets("Sheet1").Range("B" & i)
Do
ThisWorkbook.Worksheets("Sheet2").Range("B" & Sheet2_Row + 1) = Newspaper
ThisWorkbook.Worksheets("Sheet2").Range("A" & Sheet2_Row + 1) = Sheet2_Row
Sheet2_Row = Sheet2_Row + 1
j = j - 1
Loop Until j = 0

End If

Next
MsgBox ("完了しました")

End Sub

こんな感じでしょうか。
制約として、

シート2の1行目が必ず入っていること。
シート１の新聞名が入っていること。
2回実行すると、さらに下に追加されてしまうので、
再び実行する前に、シート２は1行目まで消しておくこと　があります。

他にもっとうまい書き方をされる方がいらっしゃると思いますが、参考まで

お礼

ありがとうございます。