EXCEL VBA について教えてください。

質問

EXCEL VBA　について教えてください。

条件を満たす行をコピー（挿入）さらに（数量）を分割する場合

下記のデータで

, (品名 ) , （数量） , （マスタ） , （A/B）
, A , B , C , D
1 , 商品1 , 1000 , 2000 , 0.5
2 , 商品2 , 3000 , 1000 , 3
3 , 商品3 , 3000 , 2000 , 1.5
4 , , , ,
5 , , , ,
6 , , , ,

このように（数量）＞（マスタ）の場合に（数量）/（マスタ）分を行コピー（挿入）して

, (品名 ) , （数量） , （マスタ） , （B/C）
, A , B , C , D
1 , 商品1 , 1000 , 2000 , 0.5
2 , 商品2 , 1000 , 1000 , 1.0
3 , 商品2 , 1000 , 1000 , 1.0
4 , 商品2 , 1000 , 1000 , 1.0
5 , 商品3 , 2000 , 2000 , 1
6 , 商品3 , 1000 , 2000 , 0.5

さらにＢ列の（数量）も（マスタ）以下になるように分割する。

単に行のコピーだけなら自分でもできるのですが。。。これはさっぱりです。

どうか教えてください。

回答No.1

keithin · ベストアンサー

淡々と，やるべき事をやってみます。

Sub macro1()
　Dim h As Range
　Set h = Range("A1")
　Do Until h = ""
　　If h.Offset(0, 1) > h.Offset(0, 2) Then　’多ければ
　　　h.EntireRow.Copy　　　　　　　　　　　
　　　h.Offset(1).Insert　　　　　　　　　　’行を挿入して
　　　h.Offset(0, 1) = h.Offset(0, 2)　　　’数量をマスタ量にして
　　　h.Offset(1, 1) = h.Offset(1, 1) - h.Offset(0, 1)　’挿入した行はその分減らす
　　End If
　　Set h = h.Offset(1)
　Loop
　Application.CutCopyMode = False
End Sub

回答No.3

layy

こちらは一旦締めきりのが良いです。

回答No.2

Wendy02

A2から実際にデータが始まるものとします。違う場合は、起点の部分を書き換えてください。
位置の変更がある場合でも、起点だけで済むはずです。

'//
Sub TestMacro1()
　　Dim rng As Range
　　Dim EndRow As Long
　　Dim i As Long, j As Long, n As Long, k As Long
　　Dim buf As Variant
　　Dim Ar() As Variant

　　With ActiveSheet
　　　'(タイトル行を含む)起点はここに書きます。"A1" -> "A"
　　　Set rng = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Resize(, 4)
　　End With
　　With rng
　　　　EndRow = .Rows.Count
　　　　For i = 2 To EndRow
　　　　　　k = .Cells(i, 2).Value / .Cells(i, 3).Value
　　　　　　If k > 1 Then
　　　　　　　　buf = .Cells(i, 2).Value
　　　　　　　　For j = 0 To Int(k + 0.5) - 1
　　　　　　　　　　ReDim Preserve Ar(3, n)
　　　　　　　　　　Ar(0, n) = .Cells(i, 1).Value
　　　　　　　　　　If buf > .Cells(i, 3).Value Then
　　　　　　　　　　　　Ar(1, n) = .Cells(i, 3).Value
　　　　　　　　　　Else
　　　　　　　　　　　　Ar(1, n) = buf
　　　　　　　　　　End If
　　　　　　　　　　Ar(2, n) = .Cells(i, 3).Value
　　　　　　　　　　Ar(3, n) = Ar(2, n) / .Cells(i, 3).Value
　　　　　　　　　　n = n + 1
　　　　　　　　　　buf = buf - .Cells(i, 3).Value
　　　　　　　　Next
　　　　　　Else
　　　　　　　　ReDim Preserve Ar(3, n)
　　　　　　　　Ar(0, n) = .Cells(i, 1).Value
　　　　　　　　Ar(1, n) = .Cells(i, 2).Value
　　　　　　　　Ar(2, n) = .Cells(i, 3).Value
　　　　　　　　Ar(3, n) = .Cells(i, 2).Value / .Cells(i, 3).Value
　　　　　　　　n = n + 1
　　　　　　End If
　　　　Next
　　　　.Range("A2").Resize(UBound(Ar, 2) + 1, 4).Value = Application.Transpose(Ar)
　　End With
　　Set rng = Nothing
End Sub