EXCEL 自動的に表を加工したい（マクロ）

A表（帳票）のデーターを元にｶｰﾄﾝ入数表を参照してB表を完成させたい。

表が崩れてしまうので詳細は画像にて添付いたします。

エクセル2013

マクロは自動記録を使う程度の初心者レベルなのでわかり易い
表現でご教授いただけると幸いです。

どうぞよろしくお願いいたします。

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

• 

  tom04さん回答にA表の行を追加（増えた場合）と
  列を追加した場合の編集を教えて頂けないでしょうか。

    補足日時：2019/05/16 17:15

No.3 ベストアンサー 回答者： tom04 回答日時： 2019/05/14 18:45

続けてお邪魔します。

＞追加場所がわからないので・・・

もう一度最初からコードを記載します。
前回のコードは消去し、↓のコードに変更してください。

Sub Sample2()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myCnt As Long, cnt As Long
　Dim myStr As String, wS1 As Worksheet, wS2 As Worksheet
　Dim myR

　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　　With Worksheets("Sheet3")
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 2 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "D")).ClearContents
　　　　　End If

　　　　　lastRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myR = Range(wS1.Cells(2, "A"), wS1.Cells(lastRow, "D"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 3)
　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　myDic.Add myStr, myR(i, 4)
　　　　　　　　　End If
　　　　　　　Next i

　　　　　　For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　myStr = wS2.Cells(i, "A") & "_" & wS2.Cells(i, "B") & "_" & wS2.Cells(i, "C")
　　　　　　　　If myDic.exists(myStr) Then
　　　　　　　　　myCnt = Int(wS2.Cells(i, "D") / myDic(myStr))
　　　　　　　　　　If myCnt > 0 Then '//★//
　　　　　　　　　　　Do Until cnt = myCnt
　　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　　　With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　　　　　　　　.Resize(, 3).Value = wS2.Cells(i, "A").Resize(, 3).Value
　　　　　　　　　　　　　.Offset(, 3) = myDic(myStr)
　　　　　　　　　　　　End With
　　　　　　　　　　　Loop
　　　　　　　　　　End If '//★//
　　　　　　　　End If
　　　　　　　　If wS2.Cells(i, "D") Mod myDic(myStr) > 0 Then
　　　　　　　　　With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　　　　　.Resize(, 3).Value = wS2.Cells(i, "A").Resize(, 3).Value
　　　　　　　　　　.Offset(, 3) = wS2.Cells(i, "D") Mod myDic(myStr)
　　　　　　　　　End With
　　　　　　　　End If
　　　　　　　　　cnt = 0
　　　　　　Next i
　　　　　　　Set myDic = Nothing
　　　　　　　.Activate
　　　End With
MsgBox "完了"
End Sub

※　「★」の行が追加になります。m(_ _)m

この回答へのお礼

処理できました。
こんなにも簡単に加工ができるなんて素晴らしいの一言です。
ありがとうございます。

お礼日時：2019/05/15 08:40

No.5 回答者： めぐみん_ 回答日時： 2019/05/17 05:42

勝手に横入りしますけど。

Ａ表の行が増えるとは『カートン入数表』の種類が増える事により起こり得る内容であれば問題ないと思いますが、
Ａ表だけが

abc　14　S　269
abc　14　S　125

みたいに『品番～サイズ』が重複する『在庫数』の行が増えるなら対応も必要でしょう。

あと列の追加とは今回の振り分けに影響を与えるのか、または追加された事で振り分け条件の列がずれたと言う事なのかで変わります。
なので具体的に『参照するデータと完成させたいデータの情報』を明確にされた方が良いのでは？
補足でも同じように画像を添付出来たと思いますよ。

No.4 回答者： めぐみん_ 回答日時： 2019/05/15 06:56

No.3さんの方が理解しやすいと思いますが、取り敢ず出来たので一例として載せておきます。

Sub megu()
Dim myDic As Object
Dim myLst As Object
Dim r As Range, st As String
Dim key, v

Set myDic = CreateObject("Scripting.Dictionary")
Set myLst = CreateObject("System.Collections.ArrayList")

With Worksheets("Sheet1") 'サイズ別、カートン梱包入数シート
For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
st = Join(Array(r.Value, r.Offset(, 1).Value, r.Offset(, 2).Value), "_")
myDic.Add st, Array(r.Value, r.Offset(, 1).Value, r.Offset(, 2).Value, r.Offset(, 3).Value, 0)
Next
End With

With Worksheets("Sheet2") '帳簿からのデータシート
For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
st = Join(Array(r.Value, r.Offset(, 1).Value, r.Offset(, 2).Value), "_")
v = myDic(st)
v(4) = r.Offset(, 3)
myDic(st) = v
Next
End With

For Each key In myDic.keys
Do
v = myDic(key)
myLst.Add Array(v(0), v(1), v(2), Application.Min(v(3), v(4)))
v(4) = v(4) - v(3)
If v(4) <= 0 Then Exit Do
myDic(key) = v
Loop
Next

With Worksheets("Sheet3") 'カートンラベル用
.Cells.ClearContents
.Range("A1:D1").Value = Array("品番", "カラー", "サイズ", "在庫数")
.Range("A2").Resize(myLst.Count, 4).Value = Application.Transpose(Application.Transpose(myLst.ToArray()))
End With

Set myDic = Nothing
Set myLst = Nothing
End Sub

－－－－－－

CreateObject("System.Collections.ArrayList")
は元々Ｅｘｃｅｌ機能ではありませんしまだ難しいかも知れませんね。
ここに一旦データを格納して最後に纏めて出力してます。

この回答へのお礼

ありがとうございます。

お礼日時：2019/05/15 08:41

No.2 回答者： tom04 回答日時： 2019/05/14 17:40

No.1です。

投稿後気になったので・・・
おそらく前回のコードでは在庫数が入数より少ない場合にエラーになると思います。

前回のコードの
＞myCnt = Int(wS2.Cells(i, "D") / myDic(myStr))
の次に

＞If myCnt > 0 Then
の1行を

＞Loop
の次に
＞End If

の1行をそれぞれ追加して　
INT関数で判断し、在庫が入数以上の場合のみループするようにしてください。m(_ _)m

この回答へのお礼

感動しました。
早速ご連絡頂きありがとうございます。

№1で動作確認できましたが、追加の＞Loop
の次に
＞End Ifの追加場所がわからないので
詳しく教えて頂けるとありがたいです。

お礼日時：2019/05/14 18:00

No.1 回答者： tom04 回答日時： 2019/05/14 16:51

こんにちは！

一例です。
↓の画像のような配置で

「カートン入数表」　→　Sheet1
「A表」　　　　　　→　Sheet2
にあり、
「B表」　　　　　　→　Sheet3　に表示するとします。

標準モジュールにしてください。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myCnt As Long, cnt As Long
　Dim myStr As String, wS1 As Worksheet, wS2 As Worksheet
　Dim myKey, myR

　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　　With Worksheets("Sheet3")
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 2 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "D")).ClearContents
　　　　　End If

　　　　　lastRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myR = Range(wS1.Cells(2, "A"), wS1.Cells(lastRow, "D"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 3)
　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　myDic.Add myStr, myR(i, 4)
　　　　　　　　　End If
　　　　　　　Next i

　　　　　　For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　myStr = wS2.Cells(i, "A") & "_" & wS2.Cells(i, "B") & "_" & wS2.Cells(i, "C")
　　　　　　　　If myDic.exists(myStr) Then
　　　　　　　　　myCnt = Int(wS2.Cells(i, "D") / myDic(myStr))
　　　　　　　　　　Do Until cnt = myCnt
　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　　With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　　　　　　　.Resize(, 3).Value = wS2.Cells(i, "A").Resize(, 3).Value
　　　　　　　　　　　　.Offset(, 3) = myDic(myStr)
　　　　　　　　　　　End With
　　　　　　　　　　Loop
　　　　　　　　End If
　　　　　　　　If wS2.Cells(i, "D") Mod myDic(myStr) > 0 Then
　　　　　　　　　With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　　　　　.Resize(, 3).Value = wS2.Cells(i, "A").Resize(, 3).Value
　　　　　　　　　　.Offset(, 3) = wS2.Cells(i, "D") Mod myDic(myStr)
　　　　　　　　　End With
　　　　　　　　End If
　　　　　　　　　cnt = 0
　　　　　　Next i
　　　　　　　Set myDic = Nothing
　　　　　　　.Activate
　　　End With
MsgBox "完了"
End Sub

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