エクセルで表の変換

質問

客先へ出向いて修理品を引取＆納品していますが、そのときの伝票・納品処理の省力化を目論んでます。
　今回の問合せは（２）納品一覧の作成法です。

（１）修理表
　・引取時、客先から修理依頼表を受領し、項目を追加、納品データ入力。

［修理表］10/1引取り分
注 製 品 数 | 納品１ ,　納品２
番 番 名 量 | 月/日 数 , 月/日 数
　1　1　A　2 | 10/ 5　1 , 10/ 8　1
　2　2　B　3 | 10/ 8　1 , 10/12　2
　3　1　A　4 | 10/ 5　2 , 10/12　2
　4　3　C　5 | 10/ 5　2 , 10/12　3
　5　1　A　6 | 10/ 8　3 , 10/12　3
客先より← | →自社で列追加＆入力

・この表データが月に１０件ほど。
・注番は重複なし、製番、品名は重複あり（製番が違っても同品名あり）。
・「納品１」、「納品２」は分納情報。

（２）納品一覧
　上記修理表から納品一覧を関数orマクロで作成したいのです。

［納品一覧］10月分
製 品 |　　納品月日
番 名 | 5日 , 8日 , 12日 →以下一月分
　1　A |　3　,　4　,　5
　2　B |　0　,　1　,　2
　3　C |　2　,　0　,　3

・上記は10月分。月が変われば新しい表になります。
・ここで製番:1 の10月5日納品数:3 は、上記10/1修理表、注番:1 の納品１の数:1 と注番:3 の納品１の数:2 との和です。以下同様。

　未完納修理表全部の納品データを検索、納品日に合致したら抽出して製番ごとにカウントして納品一覧表に転記するのが一般的かな？とも思いますが、ＶＢＡ初心者にとって FOR～NEXT，DO UNTIL～LOOP あたりと積み重ね処理を駆使するのは至難の業でありまして…。

　今までは関数の組合せ程度で事足りていたため、マクロはほんの初心者です。
　過去ログもあれこれ検索しましたが、発見できず。過去に同様例がありましたら番号だけでもご教示いただければ幸甚です。

回答No.1

Raistlin · ベストアンサー

1行に付き納品日が1個しか無いならピボットテーブル一発なんですけどね・・・。

メインルーチンであるNouListのトップのコメント欄を確認の上、定数定義部を適宜修正の上、以下コードをお試しください。
また、インデント保持の為、インデントを全角スペースに変換していますので、これを戻してから利用ください。

ハードコーディングをできるだけ避けたのと、コードの使いまわしのせいで、多少長くなっています。すみません。
＋＋＋＋＋＋＋
Option Explicit
Option Base 1
Sub NouList()
'　(注番,) 製番, 品名, 総数量, 納品日1, 納品数1, 納品日2, 納品数2 ....
'のフォーマットのリストを集計し
'{strNOut}シートの
'　製番, 品名, 納品日1数量, 納品日2数量 ....
'の体裁に変換します
'製番(品番)マスタは、{strNNum}({strNName})シートの{strADNum}({strADName})を先頭
'(ラベル除く)とする、空き行無しの列データとする
'ラベルを先頭行として、注番列を含めて元データを選択した状態で、マクロを実行する

　　Const iCurY As Integer = 2005 '処理する年指定
　　Const iCurM As Integer = 10 '処理する月指定
　　Const strNNum As String = "Number" '製番マスタのシート名
　　Const strADNum As String = "B2" '製番マスタデータの先頭(ラベル除く)アドレス
　　Const strNName As String = "Name" '品名マスタのシート名
　　Const strADName As String = "B2" '品番マスタデータの先頭(ラベル除く)アドレス
　　Const strNOut As String = "Output" '出力先のシート名
　　Const strADOut As String = "B2" '出力先データの先頭アドレス

　　Dim vBuf '元データセル範囲を格納
　　Dim lRN As Long, lCN As Long '元データセル範囲行数および列数
　　Dim rngNum As Excel.Range '製番マスタデータのセル範囲
　　Dim rngName As Excel.Range '品番マスタデータのセル範囲
　　Dim NLT() '日別納品数格納
　　Dim ND(31) As Boolean 'd日に納品が有ったかどうかのフラグ
　　Dim ND2(31) As Integer '納品が有った日の一覧
　　Dim lNND2 As Integer '納品が有った日の数
　　Dim flgAri As Boolean '製番i品名jの納品が有ったかどうかのフラグ
　　Dim vCurNum As Variant '現在処理中の製番またはその通し番号
　　Dim vCurName As Variant '現在処理中の品名またはその通し番号
　　Dim vCurItem As Variant '現在処理中のアイテム
　　Dim i As Long, j As Long, k As Long, l As Long 'ループカウンタ

　　With ThisWorkbook
　　　　Set rngNum = ExpRngS(.Sheets(strNNum).Range(strADNum))
　　　　Set rngName = ExpRngS(.Sheets(strNName).Range(strADName))
　　　　ReDim NLT(rngNum.Rows.Count, rngName.Rows.Count, 31)
　　End With

　　If TypeName(Selection) = "Range" Then
　　　　With Selection
　　　　　　lRN = .Rows.Count
　　　　　　lCN = .Columns.Count
　　　　End With
　　　　vBuf = Selection
　　　　For i = 2 To lRN
　　　　　　On Error GoTo InvData
　　　　　　　　With Application.WorksheetFunction
　　　　　　　　　　vCurItem = vBuf(i, 2)
　　　　　　　　　　vCurNum = .Match(vCurItem, rngNum, 0)
　　　　　　　　　　vCurItem = vBuf(i, 3)
　　　　　　　　　　vCurName = .Match(vCurItem, rngName, 0)
　　　　　　　　End With
　　　　　　On Error GoTo 0
　　　　　　For j = 5 To lCN Step 2
　　　　　　　　If vBuf(i, j) = "" Then
　　　　　　　　　　Exit For
　　　　　　　　Else
　　　　　　　　　　If Month(vBuf(i, j)) = iCurM Then
　　　　　　　　　　　　NLT(vCurNum, vCurName, Day(vBuf(i, j))) = _
　　　　　　　　　　　　　　NLT(vCurNum, vCurName, Day(vBuf(i, j))) + vBuf(i, j + 1)
　　　　　　　　　　　　ND(Day(vBuf(i, j))) = True
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next j
　　　　Next i

　　　　With ThisWorkbook.Sheets(strNOut).Range(strADOut)
　　　　　　.Offset(0, 0) = "品番"
　　　　　　.Offset(0, 1) = "品名"
　　　　　　i = 1
　　　　　　For k = 1 To 31
　　　　　　　　If ND(k) Then
　　　　　　　　　　.Offset(0, i + 1) = DateSerial(iCurY, iCurM, k)
　　　　　　　　　　ND2(i) = k
　　　　　　　　　　i = i + 1
　　　　　　　　End If
　　　　　　Next k
　　　　　　lNND2 = i - 1
　　　　　　l = 1
　　　　　　For i = 1 To 5
　　　　　　　　For j = 1 To 5
　　　　　　　　　　flgAri = False
　　　　　　　　　　For k = 1 To lNND2
　　　　　　　　　　　　If NLT(i, j, ND2(k)) <> "" Then
　　　　　　　　　　　　　　.Offset(l, k + 1) = NLT(i, j, ND2(k))
　　　　　　　　　　　　　　flgAri = True
　　　　　　　　　　　　End If
　　　　　　　　　　Next k
　　　　　　　　　　　　If flgAri Then
　　　　　　　　　　　　　　.Offset(l, 0) = Application.WorksheetFunction.Index(rngNum, i, 1)
　　　　　　　　　　　　　　.Offset(l, 1) = Application.WorksheetFunction.Index(rngName, j, 1)
　　　　　　　　　　　　　　l = l + 1
　　　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　Next i
　　　　End With
　　Else
　　　　MsgBox "集計範囲が選択されていません"
　　End If
Exit Sub
InvData:
　　MsgBox vCurItem & "がマスタに見つかりません" & Chr(10) & "集計を終了します"
End Sub

Function ExpRngS(ByVal TrgtRng As Range) As Range
'対象範囲を下方向に拡張
'引数
' TrgtRng: 処理対象範囲

　　Dim TrgtSht As Variant '処理対象シート格納
　　Dim LstRow As Long '最終行行番号格納用

　　Const xlMaxRow As Long = 65536 'ブック最終行を指定(97以降の時)
　　　　　　　　　　　　　　　　　　'5,95では16384に変更する

　　'初期化
　　Set TrgtSht = TrgtRng.Parent

　　With TrgtRng
　　　　'処理対象範囲が1セルのみのとき、拡張処理を実施
　　　　If .Cells.Count = 1 Then
　　　　　　'一度下方向にEnd(xlDown)を計算
　　　　　　LstRow = .End(xlDown).Row
　　　　　　'求めたLstRowまで範囲を拡張
　　　　　　Set ExpRngS = .Resize(LstRow - .Row + 1, 1)
　　　　'対象範囲が複数セルなら拡張せずに返す
　　　　Else
　　　　　　Set ExpRngS = TrgtRng
　　　　End If
　　End With
End Function

お礼

おぉ～っ！　回答、うれしうございます。

　早速貼り付けてあれこれ動作確認しておりますが、途中までは何とかいけるものの、エラーでダウン。もうちょっと当方が作成したテストデータ自体の調整が必要なようです。
　残念ながら今日は時間がなく、明日職場で試してみます。結果は補足のほうででも…(^^)。

　関数だけではどうあがいても解決できそうになかった（半月以上あーでもないこーでもない、と悩んでました(^^;）ので、Ｑを書き込みましたが、なかなかコメントをいただけないなぁ、やっぱり自分で汗を流すしかないか、とやむなくホコリをかぶっていたＶＢＡの参考書を引っ張り出し、付け焼刃をしかけてましたが、何と、私のやりたかった事って、こんな長い行数になるのですね。

　せっかくご回答いただいたのでこれを参考に何とかものにしたいと思います。とりあえず中間報告まで。

補足

Raistlinさん、お礼が遅くなりました。

　おかげさまで、無事出荷担当宛てにリリースすることが出来ました。何とか使ってもらえているようです。

　あれから頂いたサンプルを元にヘルプやＶＢＡハンドブックを駆使（？）して自分なりに咀嚼しながらアレンジして行ったもので、ずいぶん時間がかかりましたが、少しは私自身のＶＢＡ経験値があがったかな(^^)？と喜んでいます。

　ともあれ、大変お世話になりました。また何かありましたらよろしくお願いします。

回答No.3

Raistlin

さらに追記

{納品月/日}データは、Excelが日付データと認識するデータ(日付シリアルであり、文字データとかではない)で、年も正しく入力されていることを前提としています。

回答No.2

Raistlin

以下明記すべきと思っていたのですが、書き忘れておりました。
・オリジナルのデータでは、納品1の日付と数量が同じセルのように見えますが、集計処理を簡略化するため、別セルとしています(コメント行参照－ここで列はカンマで区切られており、これ以外の列や、空列は無いものとする)。
・「選択範囲列がラベル行を含む」が守られなかった場合をチェックしていません。

＞何と、私のやりたかった事って、こんな長い行数になるのですね。

自由度やエラーチェックを無視すれば、そんなに長くならないと思います。

例えば、マスタデータの範囲を決め打ちにして、毎回定数を書き直すようにすれば、Function ExpRngS()以下はいりませんし、最初の選択範囲のミスでエラーが出ようが知ったこっちゃ無いとかいうのであれば、エラーメッセージ部も要りません。

ですが、そこをおろそかにしすぎると、マクロがエラーを吐くたびに、オペレーターから呼び出しを食らう羽目になりますので・・・

＞なかなかコメントをいただけないなぁ
1個アドバイスすれば終わり、というネタじゃありませんからね。
自由度とか考えてちょっと時間をかけたのでさらに・・・