Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
863 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【77864】規定数で区切るには karasu 16/1/15(金) 6:13 質問[未読]
【77865】Re:規定数で区切るには β 16/1/15(金) 10:12 発言[未読]
【77866】Re:規定数で区切るには ウッシ 16/1/15(金) 10:42 回答[未読]
【77869】Re:規定数で区切るには karasu 16/1/16(土) 3:38 お礼[未読]
【77871】Re:規定数で区切るには γ 16/1/16(土) 8:44 発言[未読]
【77874】Re:規定数で区切るには karasu 16/1/16(土) 13:08 回答[未読]
【77879】Re:規定数で区切るには γ 16/1/16(土) 23:52 発言[未読]
【77880】Re:規定数で区切るには karasu 16/1/17(日) 2:10 お礼[未読]
【77873】Re:規定数で区切るには ウッシ 16/1/16(土) 9:08 回答[未読]
【77875】Re:規定数で区切るには karasu 16/1/16(土) 13:19 お礼[未読]
【77864】規定数で区切るには
質問  karasu  - 16/1/15(金) 6:13 -
引用なし
パスワード
   いつもお世話になります。

sheet1
　　　　規定数　10　<==任意の数
　　A　　　 B　　　 C
1　No　　種類　　 数量
2　 1　　みかん　　 4
3　 2　　りんご　　12
4　 3　　バナナ　　17
5　 4　　　桃　　　30
6　 5　　いちご 　 13


sheet2
　　A　　 　B　　　C　　　D
1　No　　種類　　 数量
2　 1　　みかん　 　4　　 4
3　 2　　りんご　 　6　　10
4　 2　　りんご　 　6　　 6
5　 3　　バナナ　 　4　　10
6　 3　　バナナ　　10　　10
7　 3　　バナナ　 　3　　 3
8　 4　　　桃　　 　7　　10
9　 4　　　桃　　　10　　10
10　4　　　桃　　　10　　10
11　4　　　桃　　 　3　　 3
12　5　　いちご　　 7　　10
13　5　　いちご　 　6　　 6

sheet1の表からsheet2に表のように規定数の数になった時に
次の種類のものの残りの数からまた規定数まで表示。また規定
数を超える場合は規定数(今回は10)ごとに行を追加して残りを
表示するようにしたいのです。

どうぞ宜しくお願いいたします。
【77865】Re:規定数で区切るには
発言  β  - 16/1/15(金) 10:12 -
引用なし
パスワード
   ▼karasu さん：

一例です。
勘違いあれば指摘願います。

Sub test()
　　DivItem 10
End Sub

Sub DivItem(cnt As Long)
　　Dim c As Range
　　Dim box As Long
　　Dim qtyIn As Long
　　Dim qtyBlc As Long
　　Dim qtySet As Long
　　Dim w As Variant
　　Dim dic As Object
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　For Each c In Sheets("Sheet1").Range("A1").CurrentRegion.Columns(1).Cells
　　　　If c.Row <> 1 Then
　　　　　　qtyIn = c.EntireRow.Range("C1").Value
　　　　　　qtyBlc = qtyIn
　　　　　　Do
　　　　　　　　If cnt - box >= qtyBlc Then
　　　　　　　　　　qtySet = qtyBlc
　　　　　　　　Else
　　　　　　　　　　qtySet = cnt - box
　　　　　　　　End If
　　　　　　　　
　　　　　　　　qtyBlc = qtyBlc - qtySet
　　　　　　　　w = c.EntireRow.Range("A1:C1").Value
　　　　　　　　w(1, 3) = qtySet
　　　　　　　　dic(dic.Count) = w
　　　　　　　　
　　　　　　　　box = box + qtySet
　　　　　　　　If box = cnt Then box = 0
　　　　　　　　
　　　　　　Loop While qtyBlc > 0
　　　　End If
　　Next
　　　　
　　　　　　　　　　　　　　
　　With Sheets("Sheet2")
　　　　.UsedRange.ClearContents
　　　　.Range("A1:C1").Value = Sheets("Sheet1").Range("A1:C1").Value
　　　　.Range("A2").Resize(dic.Count, 3).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
　　　　With .Range("D2").Resize(dic.Count)
　　　　　　.Formula = "=IF(MOD(SUM(C$2:C2)," & cnt & "),MOD(SUM(C$2:C2)," & cnt & ")," & cnt & ")"
　　　　　　.Value = .Value
　　　　End With
　　　　.Select
　　End With
　　　　
End Sub
【77866】Re:規定数で区切るには
回答  ウッシ  - 16/1/15(金) 10:42 -
引用なし
パスワード
   こんにちは

Sub test()
　　Dim sh1　As Worksheet
　　Dim sh2　As Worksheet
　　Dim wsh　As Worksheet
　　Dim r　　As Range
　　Dim s　　As Range
　　Dim i　　As Long
　　Dim j　　As Long
　　Const m　As Long = 3　　'規定数
　　
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　Set wsh = Worksheets.Add
　　
　　Application.ScreenUpdating = False
　　
　　sh2.UsedRange.Offset(1).ClearContents
　　
　　wsh.Range("A1:C1").Value = sh1.Range("A1:C1").Value
　　wsh.Range("D1").Value = "グループ"
　　
　　i = 2
　　For Each r In sh1.Range("A2", sh1.Range("A2").End(xlDown))
　　　　wsh.Cells(i, 1).Resize(r(1, 3), 3).Value = r.Resize(, 3).Value
　　　　i = i + r(1, 3)
　　Next
　　
　　j = wsh.Range("A" & Rows.Count).End(xlUp).Row
　　With wsh.Range("D2:D" & j)
　　　　.Formula = "=B2&INT((ROW()+" & m - 2 & ")/" & m & ")"
　　　　.Value = .Value
　　End With
　　
　　
　　wsh.Range("A1").CurrentRegion.Subtotal _
　　　　GroupBy:=4, Function:=xlCount, TotalList:=Array(3), _
　　　　Replace:=True, PageBreaks:=False, SummaryBelowData:=True
　　
　　Set s = wsh.Range("D2", wsh.Range("D2").End(xlDown).Offset(-1, 0)) _
　　　　　　　　　　.Offset(, -3).SpecialCells(xlCellTypeBlanks)
　　
　　For Each r In s
　　　　r.Offset(-1, 0).Resize(, 2).Copy _
　　　　　　sh2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
　　　　sh2.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
　　　　　　r.Offset(0, 2).Value
　　Next

　　With sh2.Range("C2", sh2.Range("C2").End(xlDown)).Offset(0, 1)
　　　　.Formula = "=IF(D1=" & m & ",C2,D1+C2)"
　　　　.Value = .Value
　　End With
　　
　　Application.DisplayAlerts = False
　　wsh.Delete
　　Application.DisplayAlerts = True
　　
　　Application.ScreenUpdating = True

End Sub
【77869】Re:規定数で区切るには
お礼  karasu  - 16/1/16(土) 3:38 -
引用なし
パスワード
   βさん、ウッシさん、こんにちは。ご回答ありがとうございます。

　早速、本ファイルに組み込みたいと思います。


関連質問なのですが今回は

規定値　50
不足分　 2 (規定値に足らなくても2以内なら次の項目ヘ)
余剰分　 2 (規定値オーバーでも2以内なら足す)
で、以下のデータを処理したとき


sheet1
no　　　種類　　　　数量
1　　　みかん　　　　148
2　　　りんご　　　　151
3　　　バナナ　　　 　76
4　　　　桃　　　　　100
5　　　いちご　　　 　34

sheet2
no　　　　種類　　　　数量　　　　
1　　　　みかん　　　　50　　　　50
1　　　　みかん　　　　50　　　　50
1　　　　みかん　　　　48　　　　48　<--　48で規定値50に満たないが不足分が
2　　　　りんご　　　　50　　　　50　　　　2以下なので次の「りんご」は
2　　　　りんご　　　　50　　　　50　　　　頭から50となる
2　　　　りんご　　　　51　　　　51　<--　規定値を超えているが余剰が
3　　　　バナナ　　　　50　　　　50　　　　2以下なので前ロットに入れる
3　　　　バナナ　　　　26　　　　26
4　　　　　桃　　　　　24　　　　50
4　　　　　桃　　　　　50　　　　50
4　　　　　桃　　　　　26　　　　26
5　　　　いちご　　　　24　　　　50
5　　　　いちご　　　　10　　　　10

上記の処理ができると大変助かります。
不躾なお願いで申し訳ございませんが教えていただけませんか。
宜しくお願い致します。
【77871】Re:規定数で区切るには
発言  γ  - 16/1/16(土) 8:44 -
引用なし
パスワード
   ▼karasu さん：
>　早速、本ファイルに組み込みたいと思います。

それもそうかもしれないが、まずはコードをよく理解する必要があるでしょう。

そして、追加質問する前に、ご自分で修正できるか検討する努力も
必要でしょう。
他人をコード制作機械かなにかのように考えていませんか？

# それにしてもどこかで聞いたような質問だなあ。
# 質問したまま放置しているわけだが、人として、気にならないのかなあ。
【77873】Re:規定数で区切るには
回答  ウッシ  - 16/1/16(土) 9:08 -
引用なし
パスワード
   こんにちは

差し替えで、標準モジュールの先頭から、

Option Explicit
Const 規定数 As Long = 10
Const 不足分 As Long = 2
Const 余剰分 As Long = 2

Sub test1_0()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim wsh As Worksheet
　　Dim r　 As Range
　　Dim s　 As Range
　　Dim i　 As Long
　　Dim j　 As Long
　　
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　Set wsh = Worksheets.Add
　
　　Application.ScreenUpdating = False
　
　　sh2.Range("A1").CurrentRegion.Offset(1).ClearContents
　
　　wsh.Range("A1:C1").Value = sh1.Range("A1:C1").Value
　　wsh.Range("D1").Value = "グループ"
　
　　i = 2
　　For Each r In sh1.Range("A2", sh1.Range("A2").End(xlDown))
　　　　wsh.Cells(i, 1).Resize(r(1, 3), 3).Value = r.Resize(, 3).Value
　　　　i = i + r(1, 3)
　　Next
　
　　Call test1_1(wsh)
　　
　　wsh.Range("A1").CurrentRegion.Subtotal _
　　　　GroupBy:=4, Function:=xlCount, TotalList:=Array(3), _
　　　　Replace:=True, PageBreaks:=False, SummaryBelowData:=True
　
　　Set s = wsh.Range("D2", wsh.Range("D2").End(xlDown).Offset(-1, 0)) _
　　　　　　　　　　.Offset(, -3).SpecialCells(xlCellTypeBlanks)
　　
　　
　　For Each r In s
　　　　r.Offset(-1, 0).Resize(, 2).Copy _
　　　　　　sh2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
　　　　sh2.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
　　　　　　r.Offset(0, 2).Value
　　Next

　　With sh2.Range("C2", sh2.Range("C2").End(xlDown)).Offset(0, 1)
　　　　.Formula = "=IF(D1>=" & 規定数 - 不足分 & ",C2,D1+C2)"
　　　　.Value = .Value
　　End With
　
　　Application.DisplayAlerts = False
　　wsh.Delete
　　Application.DisplayAlerts = True
　
　　Application.ScreenUpdating = True

End Sub

Sub test1_1(tSh As Worksheet)
　　Dim e As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　
　　With tSh
　　　　e = .Range("A1").CurrentRegion.Rows.Count
　　　　k = 1
　　　　For i = 2 To e
　　　　　　.Cells(i, 4) = k & .Cells(i, 2)
　　　　　　If Cells(i, 2) = .Cells(i + 1, 2) Then
　　　　　　　　j = j + 1
　　　　　　　　If j >= 規定数 And WorksheetFunction.CountIf( _
　　　　　　　　　　.Range(.Cells(i + 1, 2), .Cells(e, 2)), Cells(i, 2)) <= 余剰分 Then
　　　　　　　　　　　　.Cells(i, 4) = .Cells(i - 1, 4)
　　　　　　　　Else
　　　　　　　　　　If j >= 規定数 Then
　　　　　　　　　　　　k = k + 1
　　　　　　　　　　　　j = 0
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Else
　　　　　　　　If j >= 規定数 Then
　　　　　　　　　　.Cells(i, 4) = .Cells(i - 1, 4)
　　　　　　　　　　j = 0
　　　　　　　　End If
　　　　　　　　If .Cells(i, 2) = .Cells(i + 1, 2) Then
　　　　　　　　　　j = 0
　　　　　　　　Else
　　　　　　　　　　If j >= 規定数 - 不足分 - 1 And j < 規定数 Then
　　　　　　　　　　　　j = 0
　　　　　　　　　　Else
　　　　　　　　　　　　If j > 0 Then
　　　　　　　　　　　　　　j = j + 1
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
End Sub
【77874】Re:規定数で区切るには
回答  karasu  - 16/1/16(土) 13:08 -
引用なし
パスワード
   γ さん、こんにちは。


>それもそうかもしれないが、まずはコードをよく理解する必要があるでしょう。

　もちろんです。理解しないことにはファイルに組み込むことはできないことは
解っているつもりです。
　回答してくださっている方々の文を読んでもチンプンカンプンな私です。
自分の作ったエクセルファイルに組み込んで試行錯誤しながら使ってくれる
現場の人に満足(楽に)してもらえたらと奮闘してます。

>他人をコード制作機械かなにかのように考えていませんか？

　そのようには考えておりません。
独学で学んできた定年間近の私には時間がありません。若手にもマクロやVBAを
勉強してほしいのですがなかなか育たない(その気がない)のが現状です。


># それにしてもどこかで聞いたような質問だなあ。
># 質問したまま放置しているわけだが、人として、気にならないのかなあ。

　初耳です。それは私ではありません。私は以前にも質問させていただきましたが
お礼のコメントは必ずしております。『別にあなたのことを言ったわけではない』
と言われそうですが・・・。

　貴重なアドバイスありがとうございました。
【77875】Re:規定数で区切るには
お礼  karasu  - 16/1/16(土) 13:19 -
引用なし
パスワード
   ウッシ さんこんにちは

　ご回答、ありがとうございます。
大変助かります。組み込み検証まで多少時間がかかりますが活用させて
頂きます。このたびはどうもありがとうございました。

まずは御礼のご挨拶まで。
【77879】Re:規定数で区切るには
発言  γ  - 16/1/16(土) 23:52 -
引用なし
パスワード
   > ># それにしてもどこかで聞いたような質問だなあ。
> ># 質問したまま放置しているわけだが、人として、気にならないのかなあ。
>
>　　初耳です。それは私ではありません。私は以前にも質問させていただきましたが
>　お礼のコメントは必ずしております。『別にあなたのことを言ったわけではない』
> と言われそうですが・・・。
　
　「それ」って何を指していますか。何か心あたりでも？
　
　年齢を重ねたかたなら、そんなことはしないだろうが、
　たぶん若い方なんでしょうね、マナーを守らない失礼千万な人がいて困るんですよ。
　「指定数量で区切り」というタイトルでほぼ同様の質問があったのですが、
　違ったですか。それは失礼しましたね。

　βさんのものに手を加えるなら、判定条件に手を入れるのと、
　加算後のboxという変数も配列に加えて、dictionaryに保存して、
　一括書き出しすれば良いと思いますよ。
【77880】Re:規定数で区切るには
お礼  karasu  - 16/1/17(日) 2:10 -
引用なし
パスワード
   γ さん、こんにちは。

　夜勤終わりで只今帰宅いたしました。

>　「それ」って何を指していますか。何か心あたりでも？

　γさんが書かれた

>> ># それにしてもどこかで聞いたような質問だなあ。
>> ># 質問したまま放置しているわけだが、人として、気にならないのかなあ。

　上記文面です。まったく心当たりがございません。


>　「指定数量で区切り」というタイトルでほぼ同様の質問があったのですが、
>　違ったですか。それは失礼しましたね。

　いえいえ、気になさらずに。

>　βさんのものに手を加えるなら、判定条件に手を入れるのと、
>　加算後のboxという変数も配列に加えて、dictionaryに保存して、
>　一括書き出しすれば良いと思いますよ。

　ご助言ありがとうございます。参考にさせていただきます。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
863 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free