Excelマクロについて

Excelマクロのついて教えてください。

①Sheet1のB列の１行目から20行目にデータあり
②①をSheet２のB列１行目にコピペ。A列にはB列のデータの数（20個）と同じ行数に
　　"202001"と入力
③②の作業を６回繰り返す。
　・データの貼り付けは、前回データの下に貼り付け
　・A列のデータは１回目は"202001"、２回目は"202002"、３回目は"202003"
　　(以下６回目迄同じ）

①～③のマクロを教えてください。
※実際のデータ数は3000個程あります。

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

• 先ほど素晴らしい回答を頂きました。有難うございました。
  
  もう１つ教えて頂きたいのですが。
  
  202001は2020年01月の事ですが、開始が202001（2020年01月）以外でも
  （例えば202504(2025年04月）であっても）対応できるようにできますでしょうか？
  
  どうぞ宜しくお願い致します。

    補足日時：2020/02/16 15:48

No.3 ベストアンサー 回答者： めぐみん_ 回答日時： 2020/02/16 20:09

No.2です。

こんな感じでしょうか？

Sub megu_3()
Dim r1 As Range, r2 As Range
Dim i As Integer, v As Variant
Dim vv As Variant, d As Date

v = Application.InputBox("年/月とその後にカンマ区切りで期間（最大：12）を半角数字で入力してください。" _
& vbCrLf & "例: 2020/1,6", Type:=2)

If v = False Then MsgBox ("キャンセルされましたので終了します"): Exit Sub

vv = Split(v, ",")

If IsDate(vv(0) & "/1") = False Then MsgBox ("日付に変換出来ない値なので終了します"): Exit Sub

d = CDate(vv(0) & "/1")

Set r2 = Worksheets("Sheet2").Range("A1")

With Worksheets("Sheet1")
Set r1 = .Range("B1", .Cells(Rows.Count, "B").End(xlUp))
End With

For i = 0 To Val(vv(1)) - 1
r1.Copy r2.Range("B1")
r2.Resize(r1.Rows.Count).Value = Format(DateAdd("m", i, d), "yyyymm")
Set r2 = r2.Offset(r1.Rows.Count)
Next

Set r1 = Nothing
Set r2 = Nothing

End Sub

この回答へのお礼

何度も有難うございます。

私が必要としていたレベル以上のものを教えて頂きました。
本当に有難うございました。
メッセージボックスを作成し、継続する月数迄入力するなんて。

目から鱗。

本当に色々と勉強をさせて頂きました。
これで今日は安心して眠れます。

有難うございました。

お礼日時：2020/02/16 20:22

No.2 回答者： めぐみん_ 回答日時： 2020/02/16 18:55

No.1です。

改良はしてみました。
余計なものもあるかもですが、参考になれば幸いです。

Sub megu_2()
Dim r1 As Range, r2 As Range
Dim i As Integer, v As Variant, d As Date

v = Application.InputBox("年/月を半角文字で入力してください" & vbCrLf & "例: 2020/1", Type:=2)

If v = False Then MsgBox ("キャンセルされましたので終了します"): Exit Sub

If IsDate(v & "/1") = False Then MsgBox ("日付に変換出来ない値なので終了します"): Exit Sub

d = CDate(v & "/1")

Set r2 = Worksheets("Sheet2").Range("A1")

With Worksheets("Sheet1")
Set r1 = .Range("B1", .Cells(Rows.Count, "B").End(xlUp))
End With

For i = 0 To 5
r1.Copy r2.Range("B1")
r2.Resize(r1.Rows.Count).Value = Format(DateAdd("m", i, d), "yyyymm")
Set r2 = r2.Offset(r1.Rows.Count)
Next

Set r1 = Nothing
Set r2 = Nothing

End Sub

ところでスタートする年月は変動させるとしても期間は開始年月含めて6ヶ月固定で宜しいのでしょうか？

この回答へのお礼

めぐみんさん

またまたご回答頂き有難うございます。
今回もまたまた感謝です。

ご指摘の通り期間は最終的には12か月を考えております。

従いましてスタートが2020/8だと最終は2021/7となれば最高です。（12カ月間）

お礼日時：2020/02/16 19:56

No.1 回答者： めぐみん_ 回答日時： 2020/02/16 13:33

ちょっと手抜きっぽい感じはしますが。

。。

Sub megu()
Dim r1 As Range, r2 As Range
Dim i As Integer

Set r2 = Worksheets("Sheet2").Range("A1")

With Worksheets("Sheet1")
Set r1 = .Range("B1", .Cells(Rows.Count, "B").End(xlUp))
End With

For i = 1 To 6
r1.Copy r2.Range("B1")
r2.Resize(r1.Rows.Count).Value = "202" & Format(i, "000")
Set r2 = r2.Offset(r1.Rows.Count)
Next

Set r1 = Nothing
Set r2 = Nothing

End Sub

この回答へのお礼

めぐみんさん

感激!!

早速のご回答有難うございます。
これこそがやりたかったことです。
散々悩んだ事がいとも簡単に。

有難うございました。
これで前に進めます。

お礼日時：2020/02/16 15:22