初めて質問します。 VBAについて教えて下さい。 初心者です。 A列 B列 1行目 りんご 2 2行

初めて質問します。
VBAについて教えて下さい。
初心者です。


A列 B列
1行目 りんご 2
2行目 れもん 3
3行目 ばなな 1
4行目 メロン 4
・ ・ ・
・ ・ ・
・ ・ ・

上記のような表を、
下記のように別シートに作成したいです。

A列
1行目 りんご
2行目 りんご
3行目 れもん
4行目 れもん
5行目 れもん
6行目 ばなな
7行目 メロン
8行目 メロン
9行目 メロン
10行目 メロン
・ ・
・ ・
・ ・

B列に指定した回数分、
A列を行コピーしたいです。
元のシートは、最大70行目まであります。

いろいろ試してみましたが、うまくいきません。
どのようにすれば良いでしょうか？

質問者からの補足コメント

• 皆さま、早々のご回答ありがとうございます！
  
  別パターンで確認です。
  シート1に下記のデータがあるとします。
  
  A列 B列
  1行目 1 りんご
  2行目 2 れもん
  3行目 3 ばなな
  ・ ・ ・
  ・ ・ ・
  
  シート2のA列に、1と入力すると、
  シート2のB列にVLOOKUP関数で、りんご等を表示させ、
  シート2のC列にコピー回数を入力した状態で、
  シート3に先程同様のデータを作成したい場合は、
  どうすればいいですか？
  何度も申し訳ございません。
  ご教授いただければ、大変助かります。

    補足日時：2018/06/16 12:29

No.5 回答者： tom04 回答日時： 2018/06/16 17:34

No.1です。

↓の画像のような配置になっているとします。
Sheet2のC列はご自身で回数を入力してください。

Sheet2のB2セルには
=IFERROR(VLOOKUP(A2,Sheet1!A:B,2,0),"")

という数式を入れフィルハンドルで下へずぃ～～～！っとコピーしています。

VBAのコード（標準モジュール）のコードは

Sub Sample2()
　Dim i As Long, k As Long
　Dim cnt As Long, wS As Worksheet
　　Set wS = Worksheets("Sheet3")
　　　wS.Range("A:A").ClearContents
　　　With Worksheets("Sheet2")
　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If .Cells(i, "B") <> "" Then
　　　　　　For k = 1 To .Cells(i, "C")
　　　　　　　cnt = cnt + 1
　　　　　　　wS.Cells(cnt, "A") = .Cells(i, "B")
　　　　　　Next k
　　　　　End If
　　　　Next i
　　　End With
End Sub

にしてみてください。m(_ _)m

この回答へのお礼

付けていただいた画像の通りです！
大変ご丁寧にありがとうございます‼︎

お礼日時：2018/06/16 18:41

No.4 回答者： めぐみん_ 回答日時： 2018/06/16 10:57

例）

Sub megu()
Dim r1 As Range, r2 As Range
Set r2 = Worksheets("Sheet2").Range("A1")

With Worksheets("Sheet1")
For Each r1 In .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
If r1.Offset(, 1).Value <> "" Then
r2.Resize(r1.Offset(, 1)).Value = r1
Set r2 = r2.Offset(r1.Offset(, 1).Value)
End If
Next
End With

Set r2 = Nothing
End Sub

この回答へのお礼

ありがとうございます！
頑張って勉強します！

お礼日時：2018/06/16 18:38

No.3 回答者： t_fumiaki 回答日時： 2018/06/16 10:09

No.1途中で切れてしまったから、再度。

Sub WK()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

END1 = Sh1.Range("A65536").End(xlUp).Row '最終行取得
Cnt3 = 1

For Cnt1 = 2 To END1

For Cnt2 = 1 To Sh1.Range("B" & Cnt1).Value

Cnt3 = Cnt3 + 1

Sh2.Range("A" & Cnt3).Value = Sh1.Range("A" & Cnt1).Value

Next Cnt2
Next Cnt1


Application.StatusBar = False
End Sub

この回答へのお礼

ありがとうございます！
いろいろやり方があるのですね！

お礼日時：2018/06/16 18:38

No.2 回答者： t_fumiaki 回答日時： 2018/06/16 10:07

1行目にタイトルが入ってると仮定。

シート名は、Sheet1からSheet2へコピーと仮定

Sub WK()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

END1 = Sh1.Range("A65536").End(xlUp).Row '最終行取得
Cnt3 = 1

For Cnt1 = 2 To END1

For Cnt2 = 1 To Sh1.Range("B" & Cnt1).Value

Cnt3 = Cnt3 + 1

Sh2.Range("A" & Cnt3).Value = Sh1.Range("A" & Cnt1).Value

Next Cnt2
Next Cnt1
E1:
Application.S

No.1 回答者： tom04 回答日時： 2018/06/16 09:57

こんにちは！

元データはSheet1にあり、Sheet2に表示するとします。
一例です。標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, k As Long
　Dim cnt As Long, wS As Worksheet
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:A").ClearContents
　　　　With Worksheets("Sheet1")
　　　　　For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　If .Cells(i, "B") > 0 Then '//←念のため//
　　　　　　　For k = 1 To .Cells(i, "B")
　　　　　　　　cnt = cnt + 1
　　　　　　　　wS.Cells(cnt, "A") = .Cells(i, "A")
　　　　　　　Next k
　　　　　　End If
　　　　　Next i
　　　　End With
End Sub

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

この回答へのお礼

ありがとうございます！

お礼日時：2018/06/16 18:37