[[20190301170624]]　『指定数字分だけ行をコピーし、かつ連番（年月）を』（ショコラ）　ページの最後に飛ぶ

『指定数字分だけ行をコピーし、かつ連番（年月）を振りたい』（ショコラ）

初めまして
お力貸してください

次のような表があります
A社名
B月額金額
C契約年
D契約月
E契約期間

A　　　B　　　　C　 D　　　E
AA社　15000　2018 12月　　12
BB社　10000　2019　1月　　12
CC社　12000　2019　3月　　6
DD社　8000　 2019　5月　　12

Eにある契約期間分だけデータをコピーしたく、以下のような記述をしそれは実現できました。
ーーーーーーーー
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
d = sh1.Range("A65536").End(xlUp).Row
MsgBox d
k = 1
For i = 1 To d
For j = 1 To sh1.Cells(i, "E")
sh1.Range(sh1.Cells(i, "A"), sh1.Cells(i, "E")).Copy _
sh2.Cells(k, "A")
k = k + 1
Next j
Next i
End Sub
ーーーーーーーー

同時にC列とD列を組み合わせた年月もその期間分追加したいのですが、そのようなことはそもそも可能なのでしょうか？
（１行目であれば、2018 12月から2019 11月までの表示をしたい）

＜使用 Excel：Office365、使用 OS：MacOSX ＞

 手っ取り早いのが、作業列に条件に合致したかを判定させる数式を書き込んで
 それをオートフィルタで抽出するだと思います。
 マクロで判定させる事が出来るかの判断は必要なし。
（BJ） 2019/03/01(金) 17:55

この場合は、どんな結果を期待していますか

 A	  B	  C	 D	E 
 AA社	15000	2018	12月	2 
 BB社	10000	2019	1月	3

（マナ） 2019/03/01(金) 18:09

 Macで Deteadd/MonthName 関数が　使用できるか不明ですが

 Sub test()
     Dim a, b, i As Long, ii As Long, iii As Long, n As Long, myDate As Date
     a = Sheets("sheet1").Cells(1).CurrentRegion.Value
     ReDim b(1 To Application.Sum(Application.Index(a, 0, 5)), 1 To UBound(a, 2))
     For i = 2 To UBound(a, 1)
         For ii = 0 To a(i, 5) - 1
             n = n + 1
             myDate = DateSerial(a(i, 3), Val(a(i, 4)), 1)
             For iii = 1 To UBound(a, 2)
                 b(n, iii) = a(i, iii)
             Next
             b(n, 3) = Year(DateAdd("m", ii, myDate))
             b(n, 4) = MonthName(Month(DateAdd("m", ii, myDate)))
         Next
     Next
     With Sheets("sheet2").Cells(1).Resize(, UBound(a, 2))
         .CurrentRegion.ClearContents
         .Value = a
         .Rows(2).Resize(n).Value = b
     End With
 End Sub
（seiya） 2019/03/01(金) 18:12

Sub test01()

 Dim sh1 As Worksheet
 Dim sh2 As Worksheet
 Set sh1 = Worksheets("sheet1")
 Set sh2 = Worksheets("sheet2")
 Dim i As Long
 Dim d As Long
 Dim k As Long
 Dim m As Long
 Dim y As Long
 d = sh1.Range("A65536").End(xlUp).Row
 k = 1
 For i = 1 To d
    m = Val(sh1.Cells(i, "D")): y = 0

    For j = 1 To sh1.Cells(i, "E")
       sh1.Range(sh1.Cells(i, "A"), sh1.Cells(i, "E")).Copy _
       sh2.Cells(k, "A")
       sh2.Cells(k, "D") = ((m - 1) Mod 12) + 1 & "月"
       m = m + 1
       sh2.Cells(k, "C") = Val(sh2.Cells(k, "C")) + y
       If sh2.Cells(k, "D") = "12月" Then y = y + 1
       k = k + 1
    Next j
 Next i
End Sub
（mm） 2019/03/01(金) 18:14

ありがとうございます。無事に作成することができました！
今回はこちらで作成させていただきました。

 Sub test()
     Dim a, b, i As Long, ii As Long, iii As Long, n As Long, myDate As Date
     a = Sheets("sheet1").Cells(1).CurrentRegion.Value
     ReDim b(1 To Application.Sum(Application.Index(a, 0, 5)), 1 To UBound(a, 2))
     For i = 2 To UBound(a, 1)
         For ii = 0 To a(i, 5) - 1
             n = n + 1
             myDate = DateSerial(a(i, 3), Val(a(i, 4)), 1)
             For iii = 1 To UBound(a, 2)
                 b(n, iii) = a(i, iii)
             Next
             b(n, 3) = Year(DateAdd("m", ii, myDate))
             b(n, 4) = MonthName(Month(DateAdd("m", ii, myDate)))
         Next
     Next
     With Sheets("sheet2").Cells(1).Resize(, UBound(a, 2))
         .CurrentRegion.ClearContents
         .Value = a
         .Rows(2).Resize(n).Value = b
     End With
 End Sub

皆様ありがとうございます
（ショコラ） 2019/03/20(水) 17:24

コメント返信：

[ 一覧(最新更新順) ]

[[20190301170624]] 『指定数字分だけ行をコピーし、かつ連番（年月）を』（ショコラ） ページの最後に飛ぶ

[[20190301170624]]　『指定数字分だけ行をコピーし、かつ連番（年月）を』（ショコラ）　ページの最後に飛ぶ