Sub 製番合計抽出( )
　　Dim intRow As Integer
　　Dim i As Integer
　　Dim i2 As Integer
　　Dim i4 As Integer
　　Dim Seib(1 To 10) As String
　　Dim S As Integer
　　Dim intCol As Integer

　　Range("L1:O13") .ClearContents　　　　　　　　　　' 抽出領域の消去
　　intRow = Range("J3") .End(xlDown) .Row　　　　　 ' J列の端末行番検知
　　S=1　　　　　　　　　　　　　　　　　　　　　　　　' Seib( )内の番号の初期値
　　Seib(S)=Range("J4")　　　　　　　　　　 　　　　　 ' J4の製番をSeib(1)に代入する。
　　intCol=12　　　　　　　　　　　　　　　　　　　　　' 左から12列目がL列になる。
　　Cells(1 ,intCol) .Value=Seib(1)　　　　　　　　　　　' J4の製番は、抽出しなくても存在が
　　　　　　　　　　　　　　　　　　　　　　　　　　　　' 分かっているのでL1に先に書いておく。
　　Cells(3 ,intCol) .Value=Range("I4")　　　　 　 　　　' L3にI4のマークを書いている。
　　Cells(4 ,intCol) .Value=Range("K4")　　　　　　　　 ' L4にK4の金額を書いている。
　　S=S+1　　　　　　　　　　　　　　　　　　　　　　 ' Seib(S)でS=1を使ったので次は2から
　　　　　　　　　　　　　　　　　　　　　　　　　　　　' 始めるので、ここでSを繰り上げておく。
　　For i=5 To intRow　　　　　 　　　　　　　　　　　　' intRowは12になっている。
　　　　Range("J" & i) .Select　　　　　　　　　　　　　 ' 製番抽出の開始でJ5から始める。
　　　　　　　　　　　　　　　　　　　　　　　　　　　　' 選択位置が見えるようにしている。
　　　　If Range("M1") <> " " Then　　　　　　　　　　 ' M1が空白でなかったら実行する。
　　　　　intCol=Range("L1") .End(xlToRight) .Column　' 1行目の右端の列番号を検知する。
　　　　End If

　　　　For i2=1 To intCol−11　　　　　　　　　　　　　' intCol=12だから11引くと1になる。
　　　　　　If Range("J" & i)=Seib(i2) Then　　 　　　　 ' J5とSeib(1)が同じ製番なら実行する。
　　　　　　　Cells(i ,i2 +11) .Value=Range("K" & i)
　　　　　　　GoTo Jump
　　　　　　End If
　　　　Next

　　　　Seib(S)=Range("J" & i)　　　　　　　　　　　　 ' Seib(2)にJ5の製番が入る。
　　　　Cells(1 ,intCol +1) .Value=Seib(S)　　　　　　　' intCol=12に1足してCells(1,13)に書く。
　　　　Cells(3 ,intCol +1) .Value=Range("I"& i)　　　　' Cells(3,13)にマークを書く。
　　　　Cells(i ,intCol +1) .Value=Range("K" & i)　　　　' Cells(5,13)に金額を書く。
　　　　S=S+1
Jump:
　　Next

　　For i4=12 To intCol　　　　　　　　　　　　　　　　 ' 全部抽出が終わったら、intCol=5
　　　　If i4=12 Then
　　　　　Range("G3") .Value ="=" "=" "& L1"　　　　 ' L1の製番を関数でG3に書くとH3に計算値
　　　　　　　　　　　　　　　　　　　　　　　　　　　 ' が表示される。
　　　　　Range("L2") .Value=Range("H3")　　　　　　' それをコピーしてL2に書く。
　　　　End If

　　　　If i4=13 Then
　　　　　Range("G3") .Value ="=" "=" "& M1"
　　　　　Range("M2") .Value=Range("H3")
　　　　End If

　　　　If i4=14 Then
　　　　　Range("G3") .Value ="=" "=" "& N1"
　　　　　Range("N2") .Value=Range("H3")
　　　　End If

　　　　If i4=15 Then
　　　　　Range("G3") .Value ="=" "=" "& O1"
　　　　　Range("O2") .Value=Range("H3")
　　　　End If
　　Next

　　Cells(intRow+1 ,11) .Copy
　　Range(Cells(intRow+1 ,12) ,Cells(intRow+1 ,intCol)) .Select
　　ActiveSheet .Paste
　　Application .CutCopyMode=False
　　Calls(intRow+1 ,intCol+1) .Value= "=SUM(L13:O13)"
End Sub

[参考]
　Range("G3") .Value="=""=""& L1"
　Lは12列目であるが、この構文ではL1と書かないとエラーになる。

　このプログラムは、説明と確認を主にしているので、このようの後でまとめて合計を記入して
　いるが、実際のプログラムでは、製番が抽出されるたびに合計値を算出すればよい。
　　
VBAで入力するのなら、上記の様になります。
上記の表は、データの抽出の正確さを検証するために書いたものです。
実際には、データ部と製番ごとの合計金額が算出されたら良いのでこんな表は書きません。

実用的には、順に製番を入力して、その算出された合計金額をどこかにコピーすれば良いのです。
しかし、プログラムを作成して、その結果を検証することは大切なことです。

● 次のプログラムは、上記の表の結果の抽出と正確さの検証を自動で行ったものです。
　1. データベースの中から、異なった製番を抽出する。
　2. それを、L1から右に抽出順に記入して行く。
　3. その抽出された製番をG3に入力して、算出されたH3の合計値をL2から順に記入する。
　4. J4から順に下へ参照して行くときに、その仕入額をそれぞれの列に記入する。
　5. 13行目に縦計の関数を記入する。
　6. 分かりやすくするために、I列のシンボルを3行目に記入する。
　7. P13に横計を算出する関数を記入する。
上の表が、すべての製番を抽出した結果です。すべての数値が確認されました。

これを手動で製番部に入力するのならG3に、="=" & J4 と入力する。
すると、G3に =AA-111と表示されます。
G3を見てください、製番の前に = が入っています。
G3の関数を見てください。= " = " & L1 と記入されています。
合計金額のF3とL列の合計金額が同じになりました。
抽出条件文字の前に = を入れる事によって、その条件文字と完全一致だけが抽出されます。
G3に入力した製番と同じものだけを抽出するには、G3に = を入れます。
この表は、前回のデータを製番だけ入れ替えたものである。
G3にAA-111を入力すると、H3の合計金額が105000と表示された。
L列で表示されている金額と違いがある。これはM列も含まれているようである。
このように、Dsumには、文字列の左から比較して、何文字かが合致すると良しとする様に
なっているようです。
それでは、どうしたら間違いを無くせるのか、その方法を見てみましょう。
この表は、抽出した結果が正しいことを、確認するためのものである。

A3に抽出条件のAA-1234を入力すると、B3に46000が表示された。
これはデータ範囲の、D列に並ぶ製番の、★印AA-1234の4ケ所の合計値である。
F列を見れば、その合計値が正しいことが分かる。
A3にAA-1235,BB-1235を入力すると、すべての抽出結果が正しいことを確認できる。

このように、データ量にかかわらず瞬時に合計値を算出する点は便利である。
だが、問題点もある。
右上の関数入力部に入っているのが、Dsumの関数書式である。
=DSUM(D2:E11,E2,A2:A3) この関数がB3に入力されており、
D2:E11　　の範囲がデータ部
E2　　 　　の仕入額が集計条件
A2:A3 　　 が抽出条件
この書式が、Dsumの一番大事なところで、変えられない。
上のセルがタイトルで、下のセルに条件が入る。
上の表配置がDsumの基本配置である。
Dsumはワークシート関数で、データベースの中から品名などの合計値を即座に算出する。
VBAでも使用して、ワークシートでの使用と同じである。
　
基本的なマクロの習得
Dsumの使い方


実際に使っているシステムの内容で解説
　　EXCEL VBA 講座