エクセルVBAについておねがいします。

質問

エクセルマクロで下のように総量から最大200gずつに仕分けて、
さらにメーカーにおいても仕分けたいのですが、うまくいきませんでした。

メーカー　　品名　　　総量
F　 　　頭痛薬 　　600g
F　　　　胃腸薬 　350g
T 　　風邪薬 　400g
T 　　目薬　 　200g
Y 　　痛み止め　　200g
↓
↓
↓200gずつ、メーカーによって仕分ける
↓
F　　　　　　　　　T　　　　　　　　　Y
頭痛薬　200g　　 風邪薬　200g　　痛み止め　200ｇ
頭痛薬 200g　　　風邪薬　200g
頭痛薬 200g　　　目薬　　200ｇ
胃腸薬　200g
胃腸薬　150g

前回もいろいろと教えていただいたのですが、またどなたか教えていただけませんか？

回答No.2

fumufumu_2006 · ベストアンサー

こんなのではどうでしょうか？

Option Explicit

Sub test()
Dim ss As Worksheet
Dim ds As Worksheet
Dim sr As Long
Dim sc As Integer
Dim dr As Integer
Dim dc As Integer
Dim v As Integer
Dim s As String
Dim d() As String
Set ss = Sheets("sheet1") '元シート
Set ds = Sheets("sheet2") '出力シート
ds.Cells.Clear

'メーカー抽出(重複削除)
'vbNullCharはセパレータで何でもいい（カンマなど)
For sr = 2 To ss.Cells(ss.Rows.Count, 1).End(xlUp).Row
If InStr(vbNullChar & s, vbNullChar & ss.Cells(sr, 1).Value & vbNullChar) = 0 Then
s = s & ss.Cells(sr, 1).Value & vbNullChar
End If
Next

'メーカー名をdsへ
s = Replace(s, vbNullChar, vbNullChar & vbNullChar) '1行空けるために
d = Split(s, vbNullChar)
ds.Cells(1, 1).Resize(1, UBound(d)) = d

'dsの各行のデータを設定
For sr = 2 To ss.Cells(ss.Rows.Count, 1).End(xlUp).Row
dc = WorksheetFunction.Match(ss.Cells(sr, 1), ds.Cells(1, 1).Resize(1, UBound(d)), 0) '列を取得するのにmatch関数を使用
dr = ds.Cells(ds.Rows.Count, dc).End(xlUp).Row + 1
'v = ss.Cells(sr, 3)
v = Val(ss.Cells(sr, 3)) '総量にg(グラム）がついている（文字）の場合
Do
ds.Cells(dr, dc) = ss.Cells(sr, 2)
If v > 200 Then
ds.Cells(dr, dc + 1) = 200
'ds.Cells(dr, dc + 1) = "200g" 'g(グラム）をつける場合
v = v - 200
dr = dr + 1
Else
ds.Cells(dr, dc + 1) = v
'ds.Cells(dr, dc + 1) = v & "g" 'g(グラム）をつける場合
Exit Do
End If
Loop
Next
End Sub

お礼

回答ありがとうございました。
まだVBA初心者ですので、上記のコードを参考に作ってみたら
できました。
どうもありがとうございました。

回答No.1

maslkjh

このような問題は見た目より随分手間のかかる問題です。このような問題が多発するようでしたらＳＱＬなどのデータベースの導入をお勧めします。いずれにせよ一筋縄ではいきませんが。