[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『入出荷一覧入力データを在庫推移表に反映を軽くしたい』（よむちん）
こんばんは。
下記内容の質問をさせていただきます。
[入出庫一覧シート]
日付A 用途B 色柄C 部材D 寸法E 数量F
5月1日 入庫 RED 配線コード 50mm 100
5月1日 消費 RED 配線コード 50mm 35
5月2日 入庫 BLUE 皿ねじ 5*65mm 250
・・・・
[在庫推移表シート]
5/1 5/2 5/3 5/4
色柄 部材 寸法 入庫 100 0 0 0
RED 配線コード 50mm 消費 35 0 0 0
在庫数 65 65 65 65
BLUE 皿ねじ 5*65mm 入庫 250 0 0 0
消費 0 0 0 0
在庫数 250 250 250 250
・・・・
現在、入出庫一覧シートに日々入力し関数：SUMIFS（EXCEL2003ですが
標準モジュールに教えていただいた代用マクロで動かしています。）で
在庫推移表の「日付」「色柄」「部材」「寸法」で数量を拾ってきて自動転記しております。
現在、部材種類が300種類近くなり更新が非常に遅く困っており
データの更新を軽くする方法などないか教えてください。
よろしくお願いいたします。
＜ 使用 Excel：Excel2003、使用 OS：Windows10 ＞
おはようございます。
教えて貰ったと言うコードが分からないと何もコメントできません。 コードを全文アップして下さい。
（sy ） 2016/05/05(木) 07:08
sy さん指摘の通りですね。
で、それとは別といいますか質問テーマには直接関係がないのですが、 もし、入庫 RED 配線コード 50mm 100 この入庫日が 5/1 ではなく 4/30 またはそれ以前だった場合、在庫推移表シートでは在庫をどのように計算されますか？
在庫数ということの把握をどうしていおられるか、興味がありましたので、さしつかえなければ教えてください。
（β） 2016/05/05(木) 07:37
βさんからの指摘に加えて、もういくつか確認したい事がありました。
1、5/1の在庫は何処から転記してるのですか？
2、在庫推移表の日付は何か月分あるんですか？
3、年単位や月単位で在庫推移表を管理してるなら切り替わりタイミングはどのようにしてるのでしょうか？
後、過去の在庫推移表はシートで分かれてるんですか、それともブック自体が違うのですか？
（sy ） 2016/05/05(木) 07:43
sy さん βさんへ
下記が標準モジュールに入れているSUMIFSコードです。
Function SUMIFS(計算範囲, 条件範囲1, 条件1, Optional 条件範囲2 = 0, _
Optional 条件2 = 0, Optional 条件範囲3 = 0, Optional 条件3 = 0, Optional 条件範囲4 = 0, Optional 条件4 = 0)
SUMIFS = 0
For x = 1 To 計算範囲.Rows.Count
If 条件2 = 0 Then
If 条件範囲1.Rows(x) = 条件1 Then
SUMIFS = SUMIFS + 計算範囲.Rows(x)
End If
Else
If 条件3 = 0 Then
If 条件範囲1.Rows(x) = 条件1 And 条件範囲2.Rows(x) = 条件2 Then
SUMIFS = SUMIFS + 計算範囲.Rows(x)
End If
Else
If 条件4 = 0 Then
If 条件範囲1.Rows(x) = 条件1 And 条件範囲2.Rows(x) = 条件2 And 条件範囲3.Rows(x) = 条件3 Then
SUMIFS = SUMIFS + 計算範囲.Rows(x)
End If
Else
If 条件範囲1.Rows(x) = 条件1 And 条件範囲2.Rows(x) = 条件2 And 条件範囲3.Rows(x) = 条件3 And 条件範囲4.Rows(x) = 条件4 Then
SUMIFS = SUMIFS + 計算範囲.Rows(x)
End If
End If
End If
End If
Next
End Function
関数は下記を在庫推移表の各セルに入力しております。
=SUMIFS(入出庫一覧!$F$3:$F$2000,入出庫一覧!$A$3:$A$2000,"5/1"+0,入出庫一覧!$B$3:$B$2000,"入庫",入出庫一覧!$C$3:$C$2000,"RED",入力!$E$3:$E$2000,"50mm")
入出庫一覧シートと在庫推移表は同じブック内でシートで分けており、月ごとに一つのブックとして分けております。
前月の在庫数は前月bookファイルの月末在庫からトレースする関数を当月月初に入力しております。
当初は一つのブックで一年度（4月始まり〜3月終わり）分で管理しようとしたのですがデータが重くなりすぎて
再計算更新に非常に時間がかかってしまい月単位で分けて管理するようになりました。
以上よろしくお願いいたします。
（よむちん） 2016/05/05(木) 09:49
UDF名は SUMIFS ではないほうがよろしいと思います。 うっかりと、このブック上で【本当のSUMIFS】を使おうとしたときに、不具合が出ますので。
まぁ、それはさておき。
>>前月の在庫数は前月bookファイルの月末在庫からトレースする関数を当月月初に入力しております。
具体的には、どういった関数を、どのように 在庫推移シートにいれてあるのですか？
それとも、この関数は、入出庫一覧の月初日の入庫としてセットされているのですか？
加えて2点。
１．関数は下記を在庫推移表の各セルに入力しております
アップされた式には "5/1" や "RED" や "50mm" といった定数が含まれていますが、セル毎に ここを変更した数式にしてあるということですか？
２．在庫推移表のレイアウトですが、色柄 部材 寸法 といったタイトルが RED の入庫行にあり RED 等の商品名行が 消費行 にあります。 一方、BLUE のほうは BLUE等の商品名行が入庫行にあります。
ほんとに、こんなレイアウトなんですか？（感心しません）
（β） 2016/05/05(木) 11:15
ユーザー定義関数をセルに埋め込んでるんですね。
でもこれだと、最大で300部材×入出庫×31日で、1か月でも18600セルに関数が入ってる事になるんですね。 流石にそれでは遅いでしょうね。。。
集計する方法としては、DictionaryやCollectionなどの連想配列を使う方法や、配列を駆使する方法など、色々ありますが、 私からはピボットテーブルを使った方法を提示させて頂きます。
大量のデータでは検証出来なかったので、遅かったら言って下さい。 別の方法を考えます。
ただ1日の在庫の計算方法が提示が無いので、コードの中に入れる事が出来ませんでした。 そう言うのも全て提示しないと、回答者も不完全な回答しか出来ないので、手間を惜しまずに全ての情報を提示して下さい。
更新するだけなので、ピボットテーブルは予め作成されているものとしています。 ピボットテーブルの作成方法は分かりますか？
まず、在庫推移シートのレイアウトは、βさんから指摘のあるように、部材の見出し行や各データの行は規則性を持たせないと面倒な事になるので、以下のレイアウトにして下さい。 日付は日付が入っていて書式設定で5/1などになっているとしています。 またAK列に集計しやすいように作業列を追加しています。
|[A] |[B] |[C] |[D] |[E]|[F]|[G]| |[AI]|[AJ]|[AK]
[1]|色柄|部材 |寸法 | |5/1|5/2|5/3|・・・・|5/31| |
[2]|RED |配線コード|50mm |入庫 |100| 0| 0|・・・・| 0| |RED,配線コード,50mm,1
[3]| | | |消費 | 35| 0| 0|・・・・| 0| |RED,配線コード,50mm,2
[4]| | | |在庫数| 65| 65| 65|・・・・| 65| |
[5]|BLUE|皿ねじ |5*65mm|入庫 | 0|250| 0|・・・・| 0| |BLUE,皿ねじ,5*65mm,1
[6]| | | |消費 | 0| 0| 0|・・・・| 0| |BLUE,皿ねじ,5*65mm,2
[7]| | | |在庫数| 0|250|250|・・・・| 250| |
入出庫シートにもG・H列に作業列を追加しています。
|[A] |[B] |[C] |[D] |[E] |[F] |[G]|[H]
[1]|日付A |用途B|色柄C|部材D |寸法E |数量F |G |H
[2]|5月1日|入庫 |RED |配線コード|50mm | 100| |RED,配線コード,50mm,1
[3]|5月1日|消費 |RED |配線コード|50mm | 35| |RED,配線コード,50mm,2
[4]|5月2日|入庫 |BLUE |皿ねじ |5*65mm| 250| |BLUE,皿ねじ,5*65mm,1
最後に「ピボット」シートを追加して、予めピボットテーブルを作成しておきます。 ピボットテーブルは更新するだけで良いので、1回作ったら使い回しです。
|[A] |[B] |[C] |[D]
[1]|合計 |日付 | |
[2]|品名：区分 |2016/5/1|2016/5/2|(空白)
[3]|BLUE,皿ねじ,5*65mm,1 | | 250|
[4]|RED,配線コード,50mm,1| 100| |
[5]|RED,配線コード,50mm,2| 35| |
[6]|(空白) | | |
3つのシートのレイアウトは上のようにして、以下がコードになります。
Sub test()
Dim shT As Worksheet
Dim shB As Worksheet
Dim shP As Worksheet
Dim i As Long, j As Integer
Dim Date1, Item1
Dim Col1 As Integer, Row1 As Long, Row2 As Long
Dim Agr() As Long
'画面描画停止
Application.ScreenUpdating = False
'変数セット
Set shT = Sheets("在庫推移")
Set shB = Sheets("入出庫一覧")
Set shP = Sheets("ピボット")
ReDim Agr(1 To shT.Range("A1").CurrentRegion.Rows.Count - 1, 1 To 31)
Date1 = shT.Range("E1:AI1").Value
'作業列関数セット
shT.Range("AK:AK").ClearContents
shT.Range("AK2:AK" & shT.Range("D" & Rows.Count).End(xlUp).Row).Formula = _
"=IF(MOD(ROW(),3)=2,A2&"",""&B2&"",""&C2&"",""&1,IF(MOD(ROW(),3)=0,A1&"",""&B1&"",""&C1&"",""&2,""""))"
shB.Range("H2:H" & shB.Range("A" & Rows.Count).End(xlUp).Row).Formula = _
"=C2&"",""&D2&"",""&E2&"",""&IF(B2=""入庫"",1,2)"
Item1 = shT.Range("AK2").CurrentRegion.Value
'ピボットテーブル更新
shP.PivotTables(1).PivotCache.Refresh
'入出庫データ書込み
For i = 1 To 31
'日付があれば書込み
If WorksheetFunction.CountIf(shP.Range("2:2"), Date1(1, i)) Then
Col1 = WorksheetFunction.Match(CLng(Date1(1, i)), shP.Range("2:2")) - 1
'品名で検索して書込み
For j = 1 To UBound(Agr, 1) Step 3
'入庫データ
If WorksheetFunction.CountIf(shP.Range("A:A"), Item1(j, 1)) Then
Row1 = WorksheetFunction.Match(Item1(j, 1), shP.Range("A:A"), 0) - 2
Agr(j, i) = WorksheetFunction.Index(shP.Range("B3:AF1000"), Row1, Col1)
End If
'出庫データ
If WorksheetFunction.CountIf(shP.Range("A:A"), Item1(j + 1, 1)) Then
Row2 = WorksheetFunction.Match(Item1(j + 1, 1), shP.Range("A:A"), 0) - 2
Agr(j + 1, i) = WorksheetFunction.Index(shP.Range("B3:AF1000"), Row2, Col1)
End If
Next j
End If
Next i
'在庫シートに書出し
shT.Range("E2:AI" & shT.Range("A1").CurrentRegion.Rows.Count).Value = Agr
'在庫行の関数セット
shT.Range("F4:AI4").Formula = "=E4+F2-F3"
shT.Range("F4:AI4").Copy
For i = 7 To shT.Range("A1").CurrentRegion.Rows.Count Step 3
shT.Range("F" & i).PasteSpecial xlPasteAll
Next i
Application.CutCopyMode = False
'画面描画再開
Application.ScreenUpdating = True
End Sub
（sy） 2016/05/05(木) 14:02
すいません。
ピボットテーブルのフィールドリストをどうしてるか書いてませんでした。
フィールドリストは、 入出庫テーブルのA：Hを全て選択して、 行： H 列： 日付A 値： 数量F を合計で
で作成しています。
（sy） 2016/05/05(木) 14:06
syさんに整理いただいたレイアウトをベースに。 力技の集計コードです。入出庫一覧上で変更があった後に在庫推移表を表示したタイミングで自動作成します。 なお、入出庫一覧の1行目のタイトルは、日付も含めてあらかじめセット済みとの前提です。
VBE画面で左上のプロジェクトエクスプローラの ThisWorkbook をダブルクリックしてでてくるところ（ThisWorkbookモジュール)に。
Option Explicit
Dim TODO As Boolean Const FNAME As String = "入出庫一覧" Const TNAME As String = "在庫推移表"
Private Sub Workbook_Open()
TODO = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = FNAME Then TODO = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim shF As Worksheet
Dim shT As Worksheet
Dim c As Range
Dim v As Variant
Dim dic As Object
Dim k As Variant
Dim x As Long
Dim y As Long
Dim i As Long
Dim j As Long
Dim n As Long
Dim d As Date
If Sh.Name <> TNAME Then Exit Sub
If Not TODO Then Exit Sub
Set shF = Sheets(FNAME)
Set shT = Sheets(TNAME)
Set dic = CreateObject("Scripting.Dictionary")
ReDim v(1 To shF.Range("A1").CurrentRegion.Rows.Count * 3, 1 To 4 + 31) '転記用配列。行数は手抜きで多めに）
shT.Range("A1").CurrentRegion.Offset(1).ClearContents
d = shF.Range("A2").Value
n = Day(DateSerial(Year(d), Month(d) + 1, 0)) '当月日数
For Each c In shF.Range("A2", shF.Range("A" & Rows.Count).End(xlUp))
k = c.Offset(, 2).Value & vbTab & c.Offset(, 3).Value & vbTab & c.Offset(, 4).Value
If Not dic.exists(k) Then
y = y + 1
dic(k) = y
i = (dic(k) - 1) * 3
v(i + 1, 1) = c.Offset(, 2).Value
v(i + 1, 2) = c.Offset(, 3).Value
v(i + 1, 3) = c.Offset(, 4).Value
v(i + 1, 4) = "入庫"
v(i + 2, 4) = "消費"
v(i + 3, 4) = "在庫数"
For j = 5 To n + 4
If j = 5 Then
v(i + 3, j) = "=R[-2]C-R[-1]C"
Else
v(i + 3, j) = "=RC[-1]+R[-2]C-R[-1]C"
End If
Next
End If
j = Day(c.Value) + 4
i = (dic(k) - 1) * 3
Select Case c.Offset(, 1).Value
Case "入庫"
v(i + 1, j) = v(i + 1, j) + c.Offset(, 5).Value
Case "消費"
v(i + 2, j) = v(i + 2, j) + c.Offset(, 5).Value
End Select
Next
shT.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).FormulaR1C1 = v
TODO = False
Set dic = Nothing
End Sub
（β） 2016/05/05(木) 16:08
補足です。↑のコード、かなり手抜きです。年月は入出庫シートのA2のみから判断。 かつ、日付マッチングは行わず、入出庫シート、Ａ列日付の中の 【日】のみをみて、 1日なら在庫推移表のＥ列、6日ならＪ列、つまり、在庫推移表の1行目の日付は1日から末日まで 連続して記載されているという前提です。
もし、在庫推移表の1行目が、かならずしも、当月内すべての日付ではない（土日祝日は記載なし とか）なら マッチングロジックを追加します。
（β） 2016/05/05(木) 19:46
すいません。 最初のコードは、無駄が多かったので日付が多いと遅いので、コードだけ修正しました。 こちらでお願いします。
Sub test()
Dim shT As Worksheet
Dim shB As Worksheet
Dim shP As Worksheet
Dim i As Long, j As Integer
Dim Date1, pos, pvt
Dim Col1 As Integer, Row1 As Long, Row2 As Long
Dim Agr() As Long
'画面描画停止
Application.ScreenUpdating = False
'変数セット
Set shT = Sheets("在庫推移")
Set shB = Sheets("入出庫一覧")
Set shP = Sheets("ピボット")
Row1 = shT.Range("D" & Rows.Count).End(xlUp).Row
Row2 = shB.Range("A" & Rows.Count).End(xlUp).Row
ReDim Agr(1 To Row1 - 1, 1 To 31)
Date1 = shT.Range("E1:AI1").Value
'作業列関数セット
shT.Range("AK:AK").ClearContents
shT.Range("AK2:AK" & Row1).Formula = _
"=CHOOSE(MOD(ROW()-1,3)+1,"""",A2&"",""&B2&"",""&C2&"",""&1,LEFT(AK1,LEN(AK1)-1)&2)"
shB.Range("H2:H" & Row2).Formula = "=C2&"",""&D2&"",""&E2&"",""&IF(B2=""入庫"",1,2)"
'ピボットテーブル更新
shP.PivotTables(1).PivotCache.Refresh
pvt = shP.Range("A1").CurrentRegion.Value
'更新後作業列追加
shT.Range("AL2:AL" & Row1).Formula = "=MATCH(AK2,ピボット!$A$1:$A$1000,0)"
pos = shT.Range("AL2:AL" & Row1).Value
'入出庫データ書込み
For i = 1 To 31
'日付があれば書込み
If WorksheetFunction.CountIf(shP.Range("2:2"), Date1(1, i)) Then
Col1 = WorksheetFunction.Match(CLng(Date1(1, i)), shP.Range("2:2"))
'品名で検索して書込み
For j = 1 To UBound(Agr, 1) Step 3
'入庫データ
If Not IsError(pos(j, 1)) Then
Agr(j, i) = pvt(pos(j, 1), Col1)
End If
'出庫データ
If Not IsError(pos(j + 1, 1)) Then
Agr(j + 1, i) = pvt(pos(j + 1, 1), Col1)
End If
Next j
End If
Next i
'在庫シートに書出し
shT.Range("E2:AI" & Row1).Value = Agr
'在庫行の関数セット
For i = 4 To Row1 Step 3
shT.Range("F1:AI1").Rows(i).FormulaR1C1 = "=RC[-1]+R[-2]C-R[-1]C"
Next i
'画面描画再開
Application.ScreenUpdating = True
End Sub
（sy） 2016/05/05(木) 23:24
βさん、ｓｙさん早速の回答誠にありがとうございます。
先に在庫推移表のレイアウトの件ですが、こちらに貼り付けて成型する際にズレてしまったようで
行は統一して作成しております。紛らわしく申し訳ございません。
前月在庫の翌月在庫数表反映ですが、月末の棚卸数を下記のように手入力し
翌月の■■■部分に ＝[○月在庫推移表.xls]在庫数推移表!＄AJ＄4 で引っ張ってきています。
1日の在庫計算は下記の表でいえば、=C4+E2-E3=在庫数 で計算しております。
|[A] |[B] |[C] |[D] |[E]|[F]|[G]| |[AH]|[AI]|[AJ] [1]|色柄|部材 |寸法 | |4/1|4/2|4/3|・・・・|4/30| | | [2]|RED |配線コード|50mm |入庫 |100| 0| 0|・・・・| 0| | | [3]| | | |消費 | 35| 0| 0|・・・・| 0| | | [4]| | |■■■|在庫数| 65| 65| 65|・・・・| 65| | 64|←棚卸後確定値を手入力 [5]|BLUE|皿ねじ |5*65mm|入庫 | 0|250| 0|・・・・| 0| | | [6]| | | |消費 | 0| 0| 0|・・・・| 0| | | [7]| | |■■■|在庫数| 0|250|250|・・・・| 250| | 248|←棚卸後確定値を手入力
実際にお二方のコードで試しに実行してみたところ非常に早く処理できそうです。
自分では思いつかなかった方法を教えていただき勉強になっております。
βさんのコード実行時ですが、在庫推移表に入庫は問題無く反映されるのですが、消費が反映されません。いろいろと見直してはいるのですがうまくいきません。
ピボットテーブルの方には反映されており、コードはいじっておりません。
syさんのコード実行時、入出庫一覧表に入力する日付が前後すると（例 日付5/5を行入力した後、5/3の日付で
入力すると違う製品の違う日にちに飛んでいたりします。こちらもピボットテーブルは正常に反映されています。
またお二方にご質問ですが、在庫推移表に下記のように行を追加するにはコードの
どのあたりが関係してくるでしょうか？
|[A] |[B] |[C] |[D] |[E]|[F]|[G]| |[AI]|[AJ]| [1]|色柄|部材 |寸法 | |5/1|5/2|5/3|・・・・|5/31| | [2]|RED |配線コード|50mm |入庫 |100| 0| 0|・・・・| 0| | [3]| | | |消費 | 35| 0| 0|・・・・| 0| | [4]| | |■■■|在庫数 | 65| 65| 65|・・・・| 65| | [5]| | | |消費予測| 5| 10| 15|・・・・| 0| |←決まった数字を手入力しておく [6]| | | |発注予定| | | ●|・・・・| | |←●等を手入力
何卒、ご教授よろしくお願いいたします。
（よむちん） 2016/05/07(土) 02:10
新レイアウトの件は後に回し、消費が反映しない点に関して。
こちらでは反映されています。
消費が反映するsyさんのコードとβのコードで、違いは、 syさんのコードでは "入庫" という文字列は、判定材料にしておられますが、"消費"という文字列の直接判定がありません。 （ざっと見た限りですが） 一方、βのコードでは "消費"という文字列かどうかの判定があります。
たとえば 消費 の部分が 2桁の文字列ではなく、スペース等がくっついた文字列であれば、対象外になってしまいます。
１．Select Case c.Offset(, 1).Value を Select Case Trim(c.Offset(, 1).Value) に変更。
あるいは
２．Case "消費" を Case Else に変更。
いずれかで試してもらえますか？
（β） 2016/05/07(土) 07:10
おはようございます。
私の確認不足かな？ 私のテストしたデータでは日付や品名や入出庫などが前後しても並びが変わったりしないのですが、 再現できるテストデータが無くて分かりません、すいません。 問題のあった日付の並びがおかしくなると言うデータを、その部分だけ提示できますか？
行の追加は、下の部分の関数を
shT.Range("AK2:AK" & Row1).Formula = _
"=CHOOSE(MOD(ROW()-1,3)+1,"""",A2&"",""&B2&"",""&C2&"",""&1,LEFT(AK1,LEN(AK1)-1)&2)"
下のように変更して、 =CHOOSE(MOD(ROW()-1,5)+1,"""",A2&"",""&B2&"",""&C2&"",""&1,LEFT(AK1,LEN(AK1)-1)&2,"""","""")
ループで、Step 3 になっている部分を置換か手作業で全て 5 に変更して下さい。
後今日はこれから夜までin出来ませんので、帰ったら不具合の方もう一度検証してみます。
（sy） 2016/05/07(土) 07:24
＞[5]| | | |消費予測| 5| 10| 15|・・・・| 0| |←決まった数字を手入力しておく ＞[6]| | | |発注予定| | | ●|・・・・| | |←●等を手入力
そっか、今のままでは手入力の結果が消えてしまうので、新レイアウトはもう少し手を加えないといけません。 夜に修正コード提示させてもらいます。
（sy） 2016/05/07(土) 07:28
消費が反映しない件については、（β） 2016/05/07(土) 07:10 でコメントした方法を試してください。 で、新レイアウトですが、βの方式（syさんのピボット方式も同様だと思いますが）は、 入出庫一覧 から 在庫推移表 を 【作り直しています】 たとえば、入出庫一覧にREDがある状態で実行した後、入出庫一覧からREDを削除して再実行すると、在庫推移表には REDはなくなります。（あたりまえですが）
つまり、在庫推移表に 消費予測や発注予定の書きこみがあったとしても消えてしまいます。 もちろん、ちょっと煩雑なロジックを加えて、洗い替えではなく両シートのマッチングを行うという手もありますが それより、入出庫一覧に項目追加して、それらを洗い替え時に反映させる方法を強く推奨します。 用途列を使って、それら情報の行を記入するということでもできそうですし、あるいは 列を増やして、 既存の入庫ないしは消費の行の項目として 消費予測列や発注予定列を設けておきそこに記入する方法でも できそうですね。
（β） 2016/05/07(土) 09:32
たとえば入出庫一覧を
|[A] |[B] |[C] |[D] |[E] |[F]
[1] |日付 |用途 |色柄 |部材 |寸法E |数量
[2] |4月1日|在庫 |RED |配線コード|50mm | 80
[3] |4月1日|在庫 |BLUE |皿ねじ |5*65mm| 10
[4] |4月1日|消費予測|RED |配線コード|50mm | 5
[5] |4月2日|消費予測|RED |配線コード|50mm | 10
[6] |4月3日|消費予測|RED |配線コード|50mm | 15
[7] |4月3日|発注予定|RED |配線コード|50mm |●(任意の文字)
[8] |4月1日|入庫 |RED |配線コード|50mm | 100
[9] |4月1日|消費 |RED |配線コード|50mm | 35
[10]|4月2日|入庫 |BLUE |皿ねじ |5*65mm| 250
こんなレイアウトにして考えてみようと思っています。 このレイアウトがそちらの運用で問題ないかどうかわかりませんけど。
在庫や消費予測や発注予定の記述場所は、どこでもいいようにコードを組み立てる予定ですが 新しい月のブックを作成する時点で上の方にそれぞれの部材の在庫や予定を記入してもらえばいいのかなと思っています。
余談）momoさんのユーティリティ、ここしばらく2013でもOKだったんですが、またもや、NGになりましたので 2010でレイアウトをコピペしました。
（β） 2016/05/07(土) 12:50
１）在庫推移シートは、毎月、手作業で作成しておくこと ・前月シートをコピー・修正でよい ・前月から修正する箇所は、１行めの日付と前月の繰越し在庫数、発痛予測と発注予定の行 ・もし、新規の部材があれば、その欄も追加すること ２）入出庫一覧シートは、現行のものをそのまま使用します。 ３）下記マクロを実行すると、在庫推移シートの入庫と消費のデータが更新されます。
Sub test()
Dim shT As Worksheet, myTable As Range
Dim shB As Worksheet, myData As Range
Dim dic As Object
Dim k As String
Dim i As Long
Dim v
Dim chk As Boolean
Set shT = Sheets("在庫推移")
Set myTable = shT.Range("a1").CurrentRegion
Set shB = Sheets("入出庫一覧")
Set myData = shB.Range("a1").CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 1 To myTable.Rows.Count
Select Case myTable(i, 4).Value
Case "入庫"
k = myTable(i, 1).Value & myTable(i, 2).Value & myTable(i, 3).Value
myTable.Rows(i).Offset(, 4).ClearContents
Case "消費"
k = myTable(i - 1, 1).Value & myTable(i - 1, 2).Value & myTable(i - 1, 3).Value
myTable.Rows(i).Offset(, 4).ClearContents
Case "在庫数"
k = myTable(i - 2, 1).Value & myTable(i - 2, 2).Value & myTable(i - 2, 3).Value
Case "消費予測"
k = myTable(i - 3, 1).Value & myTable(i - 3, 2).Value & myTable(i - 3, 3).Value
Case "発注予定"
k = myTable(i - 4, 1).Value & myTable(i - 4, 2).Value & myTable(i - 4, 3).Value
Case ""
k = myTable(i, 1).Value & myTable(i, 2).Value & myTable(i, 3).Value
End Select
k = k & myTable(i, 4).Value
dic(k) = myTable.Rows(i).Formula
Next
For i = 2 To myData.Rows.Count
k = myData(i, 3).Value & myData(i, 4).Value & myData(i, 5).Value & myData(i, 2).Value
If dic.exists(k) Then
v = dic(k)
v(1, Day(myData(i, 1)) + 4) = myData(i, 6)
dic(k) = v
Else
chk = True
End If
Next
v = Application.Index(dic.items, 0, 0)
shT.Range("A1").CurrentRegion.Value = v
End Sub
（マナ） 2016/05/07(土) 14:36
↑のレイアウトをベースに。もう少し、すっきりさせることもできると思いますが、とりあえず。
Workbook_SheetActivate を入れ替え。 なお、1行目のタイトル、日付も、自動セットします。
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim shF As Worksheet
Dim shT As Worksheet
Dim c As Range
Dim v As Variant
Dim dic As Object
Dim k As Variant
Dim x As Long
Dim y As Long
Dim i As Long
Dim j As Long
Dim n As Long
Dim d As Date
If Sh.Name <> TNAME Then Exit Sub
If Not TODO Then Exit Sub
Application.ScreenUpdating = False
Set shF = Sheets(FNAME)
Set shT = Sheets(TNAME)
Set dic = CreateObject("Scripting.Dictionary")
ReDim v(1 To shF.Range("A1").CurrentRegion.Rows.Count * 5, 1 To 4 + 31) '転記用配列。行数は手抜きで多めに）
shT.UsedRange.ClearContents
d = shF.Range("A2").Value
n = Day(DateSerial(Year(d), Month(d) + 1, 0)) '当月日数
shT.Range("E1").Value = d - Day(d) + 1 '当月1日
shT.Range("E1").Resize(, n).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
shT.Range("A1:C1").Value = Array("色柄", "部材", "寸法")
For Each c In shF.Range("A2", shF.Range("A" & Rows.Count).End(xlUp))
k = c.Offset(, 2).Value & vbTab & c.Offset(, 3).Value & vbTab & c.Offset(, 4).Value
If Not dic.exists(k) Then
y = y + 1
dic(k) = y
i = (dic(k) - 1) * 5
v(i + 1, 1) = c.Offset(, 2).Value
v(i + 1, 2) = c.Offset(, 3).Value
v(i + 1, 3) = c.Offset(, 4).Value
v(i + 1, 4) = "入庫"
v(i + 2, 4) = "消費"
v(i + 3, 4) = "在庫数"
v(i + 4, 4) = "消費予測"
v(i + 5, 4) = "発注予定"
For j = 5 To n + 4
If j = 5 Then
v(i + 3, j) = "=RC[-2]+R[-2]C-R[-1]C"
Else
v(i + 3, j) = "=RC[-1]+R[-2]C-R[-1]C"
End If
Next
End If
j = Day(c.Value) + 4
i = (dic(k) - 1) * 5
Select Case Trim(c.Offset(, 1).Value)
Case "入庫"
v(i + 1, j) = v(i + 1, j) + c.Offset(, 5).Value
Case "消費"
v(i + 2, j) = v(i + 2, j) + c.Offset(, 5).Value
Case "在庫"
v(i + 3, 3) = c.Offset(, 5).Value
Case "消費予測"
v(i + 4, j) = c.Offset(, 5).Value
Case "発注予定"
v(i + 5, j) = c.Offset(, 5).Value
End Select
Next
shT.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).FormulaR1C1 = v
TODO = False
Set dic = Nothing
End Sub
（β） 2016/05/07(土) 14:43
こんばんわ。
ちょっと私の方で不具合を再現する事が出来ませんでした。 もしかしたら、作業列などのレイアウトが違うのかも知れません。 なので作業列は一時的に挿入して、ピボットテーブルは毎回作成する方法に変更しました。
多分1年間でも、よむちんさんの初めのファイルよりはかなり速いと思いますので、月間用と年間用の2種類作成しました。 ただ元データの量にもよるので、年間用が遅いなら月間用を使用するか、年間用を修正して半年や4半期に変更して使用して下さい。 年間用はE1セルに年度初めの日付を入力すれば、自動で日付と月棚卸を作成します。 月間用、年間用ともに、前月度や前年度の繰り越し在庫は、例示のようにC列の在庫行に手入力でお願いします。
集計シートは「在庫数推移表」なんですね、シート名変更しました。
Sub 在庫推移1月()
Dim shT As Worksheet
Dim shB As Worksheet
Dim shP As Worksheet
Dim i As Long, j As Integer
Dim Date1, pos, PvtV
Dim Col1 As Integer, Row1 As Long, Row2 As Long
Dim Agr(), Hinput
Dim DataSource As String
Dim PvtC As PivotCache
Dim PvtT As PivotTable
'画面描画停止
Application.ScreenUpdating = False
'変数セット
Set shT = Sheets("在庫数推移表")
Set shB = Sheets("入出庫一覧")
Set shP = Sheets("ピボット")
Row1 = shT.Range("D" & Rows.Count).End(xlUp).Row
Row2 = shB.Range("A" & Rows.Count).End(xlUp).Row
ReDim Agr(1 To Row1 - 1, 1 To 31)
Date1 = shT.Range("E1:AI1").Value
'ウィンドウ枠固定
shT.Activate
shT.Range("E2").Select
ActiveWindow.FreezePanes = True
'作業列関数セット
shT.Range("AK:AL").Insert
shT.Range("AK2:AK" & Row1).Formula = _
"=CHOOSE(MOD(ROW()-1,5)+1,"""",A2&"",""&B2&"",""&C2&"",""&1,LEFT(AK1,LEN(AK1)-1)&2,"""","""")"
shB.Range("G:G").Insert
shB.Range("G2:G" & Row2).Formula = "=C2&"",""&D2&"",""&E2&"",""&IF(B2=""入庫"",1,2)"
shB.Range("G1").Value = "G"
'ピボットテーブル作成
DataSource = shB.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1, External:=True)
shP.Cells.Delete
Set PvtC = ThisWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataSource)
Set PvtT = PvtC.CreatePivotTable(TableDestination:=shP.Name & "!R1C1", _
TableName:="ﾋﾟﾎﾞｯﾄ1", _
DefaultVersion:=xlPivotTableVersion10)
With PvtT
With .PivotFields("G")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("日付A")
.Orientation = xlColumnField
.Position = 1
End With
.AddDataField .PivotFields("数量F"), "合計 / 数量F", xlSum
End With
PvtV = shP.Range("A1").CurrentRegion.Value
'更新後作業列追加
shT.Range("AL2:AL" & Row1).Formula = "=MATCH(AK2,ピボット!$A$1:$A$1000,0)"
pos = shT.Range("AL2:AL" & Row1).Value
'在庫数計算式・手入力項目追加
Hinput = shT.Range("E2:AI" & Row1).Value
For i = 3 To UBound(Agr, 1) Step 5
For j = 1 To 31
Agr(i, j) = "=RC[-1]+R[-2]C-R[-1]C"
If Hinput(i + 1, j) <> "" Then Agr(i + 1, j) = Hinput(i + 1, j)
If Hinput(i + 2, j) <> "" Then Agr(i + 2, j) = Hinput(i + 2, j)
Next j
Agr(i, 1) = "=RC3+R[-2]C-R[-1]C"
Next i
'入出庫データ書込み
For i = 1 To 31
'日付があれば書込み
If WorksheetFunction.CountIf(shP.Range("2:2"), Date1(1, i)) Then
Col1 = WorksheetFunction.Match(CLng(Date1(1, i)), shP.Range("2:2"))
'品名で検索して書込み
For j = 1 To UBound(Agr, 1) Step 5
'入庫データ
If Not IsError(pos(j, 1)) Then
Agr(j, i) = PvtV(pos(j, 1), Col1)
End If
'出庫データ
If Not IsError(pos(j + 1, 1)) Then
Agr(j + 1, i) = PvtV(pos(j + 1, 1), Col1)
End If
Next j
End If
Next i
'在庫シートに書出し
shT.Range("E2:AI" & Row1).Value = Agr
'作業列削除
shB.Range("G:G").Delete
shT.Range("AK:AL").Delete
'画面描画再開
Application.ScreenUpdating = True
End Sub
Sub 在庫推移1年()
Dim shT As Worksheet
Dim shB As Worksheet
Dim shP As Worksheet
Dim i As Long, j As Integer
Dim Date1, pos, PvtV
Dim Col1 As Integer, Row1 As Long, Row2 As Long
Dim Agr(), Hinput
Dim DataSource As String
Dim PvtC As PivotCache
Dim PvtT As PivotTable
Dim OldDate As String
'画面描画停止
Application.ScreenUpdating = False
'変数セット
Set shT = Sheets("在庫数推移表")
Set shB = Sheets("入出庫一覧")
Set shP = Sheets("ピボット")
Row1 = shT.Range("D" & Rows.Count).End(xlUp).Row
Row2 = shB.Range("A" & Rows.Count).End(xlUp).Row
ReDim Agr(1 To Row1 - 1, 1 To 378)
Date1 = shT.Range("E1:NR1").Value
'日付セット
shT.Range("F1:NQ1").Formula = "=IF(ISERROR(MONTH(E1)),D1+1,IF(MONTH(E1+1)<>MONTH(E1),MONTH(E1)&""月棚卸"",E1+1))"
shT.Range("NR1").Formula = "=IF(ISERROR(MONTH(NQ1)),"""",IF(MONTH(NQ1+1)<>MONTH(NQ1),MONTH(NQ1)&""月棚卸"",NQ1+1))"
shT.Columns("E:NQ").EntireColumn.AutoFit
'ウィンドウ枠固定
shT.Activate
shT.Range("E2").Select
ActiveWindow.FreezePanes = True
'作業列関数セット
shT.Range("NT:NU").Insert
shT.Range("NT2:NT" & Row1).Formula = _
"=CHOOSE(MOD(ROW()-1,5)+1,"""",A2&"",""&B2&"",""&C2&"",""&1,LEFT(NT1,LEN(NT1)-1)&2,"""","""")"
shB.Range("G:G").Insert
shB.Range("G2:G" & Row2).Formula = "=C2&"",""&D2&"",""&E2&"",""&IF(B2=""入庫"",1,2)"
shB.Range("G1").Value = "G"
'ピボットテーブル作成
DataSource = shB.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1, External:=True)
shP.Cells.Delete
Set PvtC = ThisWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataSource)
Set PvtT = PvtC.CreatePivotTable(TableDestination:=shP.Name & "!R1C1", _
TableName:="ﾋﾟﾎﾞｯﾄ1", _
DefaultVersion:=xlPivotTableVersion10)
With PvtT
With .PivotFields("G")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("日付A")
.Orientation = xlColumnField
.Position = 1
End With
.AddDataField .PivotFields("数量F"), "合計 / 数量F", xlSum
End With
PvtV = shP.Range("A1").CurrentRegion.Value
'更新後作業列追加
shT.Range("NU2:NU" & Row1).Formula = "=MATCH(NT2,ピボット!$A$1:$A$1000,0)"
pos = shT.Range("NU2:NU" & Row1).Value
'在庫数計算式・手入力項目追加
Hinput = shT.Range("E1:NR" & Row1).Value
For i = 3 To UBound(Agr, 1) Step 5
For j = 1 To 378
If IsDate(Hinput(1, j)) Then
Agr(i, j) = "=RC[-1]+R[-2]C-R[-1]C"
Else
Agr(i, j) = Hinput(i + 1, j)
End If
If Hinput(i + 2, j) <> "" Then Agr(i + 1, j) = Hinput(i + 2, j)
If Hinput(i + 3, j) <> "" Then Agr(i + 2, j) = Hinput(i + 3, j)
Next j
Agr(i, 1) = "=RC3+R[-2]C-R[-1]C"
Next i
'入出庫データ書込み
For i = 1 To 378
'日付があれば書込み
If WorksheetFunction.CountIf(shP.Range("2:2"), Date1(1, i)) And Date1(1, i) <> "" Then
Col1 = WorksheetFunction.Match(CLng(Date1(1, i)), shP.Range("2:2"))
'品名で検索して書込み
For j = 1 To UBound(Agr, 1) Step 5
'入庫データ
If Not IsError(pos(j, 1)) Then
Agr(j, i) = PvtV(pos(j, 1), Col1)
End If
'出庫データ
If Not IsError(pos(j + 1, 1)) Then
Agr(j + 1, i) = PvtV(pos(j + 1, 1), Col1)
End If
Next j
End If
Next i
'在庫シートに書出し
shT.Range("E2:NR" & Row1).Value = Agr
'作業列削除
shB.Range("G:G").Delete
shT.Range("NT:NU").Delete
'画面描画再開
Application.ScreenUpdating = True
End Sub
（sy） 2016/05/07(土) 22:50
マナさん βさん syさん
早速の回答ありがとうございました。
それぞれのコードを使わせていただき描いていた通りにいけそうです。
実際に運用させて頂き、また何かありました時に質問させて頂けたらと思います。
本当にありがとうございました。
（よむちん） 2016/05/09(月) 08:47
マナさん βさんへ
入出庫一覧の入力ですが、現在同日・同商品の入庫消費ともに分けて入力する場合があるので
数量を合計したものを在庫数推移表に反映することは可能でしょうか？
今こちらのコードで試して気づいたのですが、最新の入力のみ反映されているようです。
お手数ですがよろしくお願いいたします。
ｓｙさんへ
現在ｓｙさんの在庫推移（月単位）のコードでマクロを実行すると
実行時エラー1004 アプリケーション定義及びオブジェクト定義エラーとなってしまいます。
またマクロを実行するたびに「入出庫一覧」のG列に入る(=C2&","&D2&","&E2&","&IF(B2="入庫",1,2)が
H列、I列・・・と横にずれて追加されて入ってきます。
同じく「在庫数推移表」シートも最初 AK列に入り、次に実行するとAM列→AO列と横にずれながら
追加されて入ってきます。
「ピボット」シートはGの商品は自動で取り込まれるのですが日付と数量が「フィールドにドラッグ」状態で
まったく反映されていないようです。
上記ピボットに日付と数量が反映されませんので在庫数推移表には数字は反映されておりません。
度々申し訳ございませんがご教授よろしくお願いいたします。
（よむちん） 2016/05/09(月) 12:58
>>最新の入力のみ反映されているようです
そうですか？ 入庫と消費に関しては同日のものがあれば合算していますけど？ 新しく追加した在庫、発注予定、消費予測については、新しいものを上書きにしていますが ここも合算と言うことならもちろん対応可能です。
念のため
|[A] |[B] |[C] |[D] |[E] |[F]
[1] |日付 |用途 |色柄 |部材 |寸法E |数量
[2] |4月1日|在庫 |RED |配線コード|50mm | 80
[3] |4月1日|在庫 |BLUE |皿ねじ |5*65mm| 10
[4] |4月1日|消費予測|RED |配線コード|50mm | 5
[5] |4月2日|消費予測|RED |配線コード|50mm | 10
[6] |4月3日|消費予測|RED |配線コード|50mm | 15
[7] |4月3日|発注予定|RED |配線コード|50mm |●(任意の文字)
[8] |4月1日|入庫 |RED |配線コード|50mm | 100
[9] |4月1日|入庫 |RED |配線コード|50mm | 100
[10]|4月1日|消費 |RED |配線コード|50mm | 35
[11]|4月1日|消費 |RED |配線コード|50mm | 35
[12]|4月2日|入庫 |BLUE |皿ねじ |5*65mm|
こんなデータで実行。結果は以下の通り、4/1 の入庫、消費ともに合算されています。
|[A] |[B] |[C] |[D] |[E] |[F] |[G]
[1] |色柄 |部材 |寸法 | |4月1日|4月2日|4月3日
[2] |RED |配線コード|50mm |入庫 | 200| |
[3] | | | |消費 | 70| |
[4] | | | 80|在庫数 | 210| 210| 210
[5] | | | |消費予測| 5| 10| 15
[6] | | | |発注予定| | |●(任意の文字)
[7] |BLUE |皿ねじ |5*65mm|入庫 | | 250|
[8] | | | |消費 | | |
[9] | | | 10|在庫数 | 10| 260| 260
[10]| | | |消費予測| | |
[11]| | | |発注予定| | |
（β） 2016/05/09(月) 13:49
すみません自分の勘違いでした。合算された数字が反映されておりました。
お手数おかけしました。
ｓｙさんへ
上記エラーの件ですが、
With .PivotFields("日付A")
.Orientation = xlColumnField
.Position = 1
End With
.AddDataField .PivotFields("数量F"), "合計 / 数量F", xlSum
上記部分を（"日付")（"数量"）へ変更したところ大丈夫のようでした。
もうひとつ質問ですが、在庫数推移表の手入力行を増やす場合は
'作業列関数セット
shT.Range("AK:AL").Insert
shT.Range("AK2:AK" & Row1).Formula = _
"=CHOOSE(MOD(ROW()-1,6 ←※ここを5から6 )+1,"""",A2&"",・・・・・・
'在庫数計算式・手入力項目追加
Hinput = shT.Range("E2:AI" & Row1).Value
For i = 3 To UBound(Agr, 1) Step 6 ←※ここを 5から6
'日付があれば書込み
If WorksheetFunction.CountIf(shP.Range("2:2"), Date1(1, i)) Then
Col1 = WorksheetFunction.Match(CLng(Date1(1, i)), shP.Range("2:2"))
'品名で検索して書込み
For j = 1 To UBound(Agr, 1) Step 6 ←※ここを 5から6
で行数は増やせているようなのですが、更新した際に消えない仕様にするには
あとどの部分のコードを改変追加したらよいでしょうか？
お手数ですがよろしくお願いいたします。
（よむちん） 2016/05/09(月) 18:17
これで合算になります。
＞ v(1, Day(myData(i, 1)) + 4) = myData(i, 6) ↓ v(1, Day(myData(i, 1)) + 4) = v(1, Day(myData(i, 1)) + 4)+ myData(i, 6)
（マナ） 2016/05/09(月) 18:59
＞もうひとつ質問ですが、在庫数推移表の手入力行を増やす場合は
に対応しました。
Sub test2()
Dim shT As Worksheet, myTable As Range
Dim shB As Worksheet, myData As Range
Dim dic As Object
Dim k As String
Dim i As Long
Dim v
Dim d As Long
Dim chk As Boolean
Set shT = Sheets("在庫推移")
Set myTable = shT.Range("a1").CurrentRegion
Set shB = Sheets("入出庫一覧")
Set myData = shB.Range("a1").CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 1 To myTable.Rows.Count
Select Case myTable(i, 4).Value
Case "入庫"
k = myTable(i, 1).Value & myTable(i, 2).Value & myTable(i, 3).Value & myTable(i, 4).Value
myTable.Rows(i).Offset(, 4).ClearContents
Case "消費"
k = myTable(i - 1, 1).Value & myTable(i - 1, 2).Value & myTable(i - 1, 3).Value & myTable(i, 4).Value
myTable.Rows(i).Offset(, 4).ClearContents
Case Else
k = i
End Select
dic(k) = myTable.Rows(i).Formula
Next
For i = 2 To myData.Rows.Count
k = myData(i, 3).Value & myData(i, 4).Value & myData(i, 5).Value & myData(i, 2).Value
If dic.exists(k) Then
v = dic(k)
d = Day(myData(i, 1)) + 4
v(1, d) = Val(v(1, d)) + myData(i, 6)
dic(k) = v
Else
chk = True
End If
Next
v = Application.Index(dic.items, 0, 0)
shT.Range("A1").CurrentRegion.Value = v
End Sub
（マナ） 2016/05/09(月) 20:26
こんばんわ。
日付A、数量F じゃ無かったんですね。 それと1年版は、2003なので、IV列までしか無いから無理でしたね。 すいませんでした。
行を追加する場合は、重複しますが。
"=CHOOSE(MOD(ROW()-1,6 ←ここを行に合わせて増やすのと、 )+1,"""",A2&"",""&B2&"",""&C2&"",""&1,LEFT(AK1,LEN(AK1)-1)&2,"""","""","""" ←ここも増やす行数に合わせて多くして下さい)"
Stepの部分は合ってます。行数に合わせて下さい。
後もう1個所、
'在庫数計算式・手入力項目追加
Hinput = shT.Range("E2:AI" & Row1).Value
For i = 3 To UBound(Agr, 1) Step 5
For j = 1 To 31
Agr(i, j) = "=RC[-1]+R[-2]C-R[-1]C"
If Hinput(i + 1, j) <> "" Then Agr(i + 1, j) = Hinput(i + 1, j)
If Hinput(i + 2, j) <> "" Then Agr(i + 2, j) = Hinput(i + 2, j)
If Hinput(i + 3, j) <> "" Then Agr(i + 3, j) = Hinput(i + 3, j) ←ここを増やした分だけ+の数値を1づつ加算して、手入力の行の分だけ追加して下さい。
Next j
（sy） 2016/05/09(月) 21:04
おはようございます。
今後も行を追加して、手入力項目が増える可能性があるなら、毎回修正は誤動作の原因になるので、 修正する部分を1個所で済むように変更しました。
変数宣言部の、
Const MEnt As Integer = 5 ←ここを行数に合わせて変更して下さい。
Sub 在庫推移1月()
Dim shT As Worksheet
Dim shB As Worksheet
Dim shP As Worksheet
Dim i As Long, j As Integer, k As Integer
Dim Date1, pos, PvtV
Dim Col1 As Integer, Row1 As Long, Row2 As Long
Dim Agr(), Hinput
Dim DataSource As String
Dim PvtC As PivotCache
Dim PvtT As PivotTable
Const MEnt As Integer = 5
'画面描画停止
Application.ScreenUpdating = False
'変数セット
Set shT = Sheets("在庫数推移表")
Set shB = Sheets("入出庫一覧")
Set shP = Sheets("ピボット")
Row1 = shT.Range("D" & Rows.Count).End(xlUp).Row
Row2 = shB.Range("A" & Rows.Count).End(xlUp).Row
ReDim Agr(1 To Row1 - 1, 1 To 31)
Date1 = shT.Range("E1:AI1").Value
'ウィンドウ枠固定
shT.Activate
shT.Range("E2").Select
ActiveWindow.FreezePanes = True
'作業列関数セット
shT.Range("AK:AL").Insert
shT.Range("AK2:AK" & Row1).Formula = _
"=IF(D2=""入庫"",A2&"",""&B2&"",""&C2&"",""&1,IF(D2=""消費"",LEFT(AK1,LEN(AK1)-1)&2,""""))"
shB.Range("G:G").Insert
shB.Range("G2:G" & Row2).Formula = "=C2&"",""&D2&"",""&E2&"",""&IF(B2=""入庫"",1,2)"
shB.Range("G1").Value = "G"
'ピボットテーブル作成
DataSource = shB.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1, External:=True)
shP.Cells.Delete
Set PvtC = ThisWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=DataSource)
Set PvtT = PvtC.CreatePivotTable(TableDestination:=shP.Name & "!R1C1", _
TableName:="ﾋﾟﾎﾞｯﾄ1", _
DefaultVersion:=xlPivotTableVersion10)
With PvtT
With .PivotFields("G")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("日付")
.Orientation = xlColumnField
.Position = 1
End With
.AddDataField .PivotFields("数量"), "合計 / 数量", xlSum
End With
PvtV = shP.Range("A1").CurrentRegion.Value
'更新後作業列追加
shT.Range("AL2:AL" & Row1).Formula = "=MATCH(AK2,ピボット!$A$1:$A$1000,0)"
pos = shT.Range("AL2:AL" & Row1).Value
'在庫数計算式・手入力項目追加
Hinput = shT.Range("E2:AI" & Row1).Value
For i = 3 To UBound(Agr, 1) Step MEnt
For j = 1 To 31
Agr(i, j) = "=RC[-1]+R[-2]C-R[-1]C"
For k = 1 To MEnt - 3
If Hinput(i + k, j) <> "" Then Agr(i + k, j) = Hinput(i + k, j)
Next k
Next j
Agr(i, 1) = "=RC3+R[-2]C-R[-1]C"
Next i
'入出庫データ書込み
For i = 1 To 31
'日付があれば書込み
If WorksheetFunction.CountIf(shP.Range("2:2"), Date1(1, i)) Then
Col1 = WorksheetFunction.Match(CLng(Date1(1, i)), shP.Range("2:2"))
'品名で検索して書込み
For j = 1 To UBound(Agr, 1) Step MEnt
'入庫データ
If Not IsError(pos(j, 1)) Then
Agr(j, i) = PvtV(pos(j, 1), Col1)
End If
'出庫データ
If Not IsError(pos(j + 1, 1)) Then
Agr(j + 1, i) = PvtV(pos(j + 1, 1), Col1)
End If
Next j
End If
Next i
'在庫シートに書出し
shT.Range("E2:AI" & Row1).Value = Agr
'作業列削除
shB.Range("G:G").Delete
shT.Range("AK:AL").Delete
'画面描画再開
Application.ScreenUpdating = True
End Sub
（sy） 2016/05/10(火) 07:29
こんにちは。
コード改変誠にありがとうございました。
実際に使わせて頂きながら更に勉強し活かしていきます。
また何かありました時は、ご教授、お力添えよろしくお願いいたします。
（よむちん） 2016/05/11(水) 12:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.