親子におすすめの新型プラネタリウムとは?

A表(帳票)のデーターを元にカートン入数表を参照してB表を完成させたい。

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

エクセル2013

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

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

「EXCEL 自動的に表を加工したい(マク」の質問画像

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

  • うーん・・・

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

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

A 回答 (5件)

続けてお邪魔します。



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

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

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
    • good
    • 1
この回答へのお礼

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

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

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



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

abc 14 S 269
abc 14 S 125

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

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

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")
は元々Excel機能ではありませんしまだ難しいかも知れませんね。
ここに一旦データを格納して最後に纏めて出力してます。
    • good
    • 1
この回答へのお礼

ありがとうございます。

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

No.1です。



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

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

>If myCnt > 0 Then
の1行を

>Loop
の次に
>End If

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

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

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

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

こんにちは!



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

「カートン入数表」 → 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
「EXCEL 自動的に表を加工したい(マク」の回答画像1
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング