購入部品注文データベース.xlsm

材料注文データベース.xlsm
※参照ファイル
 ファイルはすべて指定の名前で、Eドライブに保存してください。
 
SIMADA−注文書作成.xlsmと
Eドライブに保存してください。
YAMADA−注文書作成.xlsmと
Eドライブに保存してください。
加工部品注文データベース.xlsmと
Eドライブに保存してください。
仕入先データベース.xlsmとして
Eドライブに保存してください。
このファイル keiyaku2ですが
keiyaku.xlsとEドライブに
保存してください。
注文書作成.xlsmと
Eドライブに保存
してください。
※構文が長くて途中で
 折り返したい場合は
 [スペース]-キーボードの[ろ]
 をShiftと共に押す-[スペース]
 を入れてEnterを押す。
Sheets("部品"). Select
ActiveSheet. Unprotect              ' 部品シートの保護を解除する。

ActiveSheet. Shapes("正方形/長方形 40"). Select  ' ボタンを選択する。
Selection. Characters. Text = ""          ' 文字を消去する。

ActiveSheet. Shapes("正方形/長方形 40"). Select
Selection. OnAction = ""              ' 登録マクロを取り消す。

Range("Y1"). Value = "0"
Range("A1"). Select
ActiveSheet. Protect DrawingObjects:= True, Contents:= True, Scenarios:= True
                          ' シートに保護を適用する。
ActiveWorkbook. Save      ' 開いているファイルを保存する。
Application. Quit        ' Excelを終了する。
このボタンを押すと、[終了]マクロを実行する。
If TextBox3. Text <> "" Then Goto JumpEnd
strNam = "" & TextBox1. Text    ' 上の検索で無かったら を付けて再検索する。

For i = 5 To 500
  N = Len(strNam)
  strNam2 = Left(strNam, N)
    If Left(Range("C" & i), N) = strNam2 Then
      TextBox3. Text = Range("C" & i). Value
      Range("C" & i). Offset(0, −1). Select
      TextBox2. Text = ActiveCell. Value
      Sheets(strSh). Select
      Exit Sub
    End If
Next

strNam = "" & TextBox1. Text    ' 上の検索で無かったら を付けて再検索する。
Sheets("コード"). Activate
For i = 5 To 500          ' コードシートを5行目から下へ500行まで
  N = Len(strNam)         ' 入力した会社名の文字数を数えてNに代入する。
  strNam2 = Left(strNam, N)    ' 入力した文字列の左から3ケを strNam2に代入する。

  If Left(Range("C" & i), N) = strNam2 Then   ' コードの列の i 行目の文字列の左から
                           ' N文字と strNam2が同じなら、
    TextBox3. Text = Range("C" & i). Value   ' TextBox3にC列の i 行目の文字を記入する。
    Range("C" & i). Offset(0, −1). Select     ' C列の一つ左のコードNo列セルを選択する。
    TextBox2. Text = ActiveCell. Value     ' そのセルの値をTextBox2に記入する。
    Sheets(strSh). Select            ' 元のシートに戻る。
    Exit Sub                   ' プログラムの終了
  End If
Next                        ' 抽出するまで For に戻る。
strNam = TextBox1. Text        ' 入力した会社名をstrNamに代入する。
strSh = Range("A1"). Parent. Name  ' 現在A1の存在するシート名をstrShに代入する。
会社名に識別できる文字列を入力する。
[検索]ボタンを押すと、
その会社の仕入先コードが表示される。
メッセージBoxに確認の会社名が表示される。
文字列の何文字かが一致して表示されても、
他の会社名が存在する場合の確認ができる。
Sub 仕入先コードの検索( )
  仕入先コード検索.Show vbModeless   ' 移動自由のモードでフォームを開く。
End Sub
このボタンを押すと、[仕入先コードの検索]マクロを実行する。
If Sheets("メニュー"). Range("K10"). Value <> 3210 Then   ' 3210でなかったら
  Sheets("メニュー"). Range("K10"). Value = "Non Pasu"    ' Non Pasuと表示する。
  Exit Sub                          ' プログラムを終了する。
End IF
Sheets("メニュー"). Range("K10"). Value = "****"       ' パスワードが正しかったら
                                ' 実行して星マークに替える。

●Sub YAMADA番号取得( )
  Dim Cnn As ADODB. Connection      ' 相手のファイルを開かないでデータを取得する
  Dim Rec As ADODB. Recordset       ' 為に必要な変数定義。

  Worksheets("発行番号"). Cells. Clear    ' このファイルの発行番号を消去する。

  Set Cnn = New ADODB. Connection
  Cnn. Provider = "Microsoft. ACE.OLEDB. 12.0"
  Cnn. Properties("Extended Properties") = "Excel 12.0"
  Cnn. Open "E" & ":" & "\" & "YAMADA−注文書作成. xlsm"   ' ファイルを開いているが
                                  ' 表示はしない。
  Set Rec = New ADODB. Recordset
  Set Rec. ActiveConnection = Cnn
  Rec. Open"[DAT1$C3:D7]" , , adOpenKeyset, adLockPessimistic, adCmdTable
              ' 指定した範囲を記憶する。
  Worksheets("発行番号"). Range("C3"). CopyFromRecordset Rec
              ' 記憶した内容を貼り付ける。
  Rec. Close       ' 変数の開放処理
  Cnn. Close
  Set Rec = Nothing   ' 変数の開放処理
  Set Cnn = Nothing
 End Sub

●Sub 更新配信( )
  intNum = Sheets("発行番号"). Range("D4")
  strCod = Sheets("発行番号"). Range("D5")

  If strCod = "YA" Then strName = "YAMADA"

  Sheets("DAT1"). Range("D4"). Value = intNum
  Sheets("DAT1"). Range("D6"). Value = strCod
  Sheets("メニュー"). Range("K5"). Value = strName

  Kill "E:\注文書作成.xlsm"       ' 現在 Eドライブにあるファイルを削除する。

  ActiveWorkbook. SaveAs Filename:= "E:\注文書作成.xlsm", FileFormat:= _
    xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                     ' このファイルを同じファイル名で保存する。

  Kill "E:\YAMADA−注文書作成.xlsm"   ' 現在 Eドライブにあるファイルを削除する。

  ActiveWorkbook. SaveAs Filename:= "E:\YAMADA−注文書作成.xlsm", FileFormat:= _
    xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                     ' このファイルを同じファイル名で保存する。

●仕入先コード検索

注文書発行ファイルの[メニュー]画面
  Call YAMADA 番号取得    ' この二つによって、更新に移行するための
  Call SIMADA 番号取得     ' 現在の注文書番号を取得している。

注文書作成ファイル[DAT1]シートと[発行番号]シート
このボタンを押すと、[更新配信]マクロを実行する。
●注文書作成ファイルは、手配する担当者が複数の場合は、各個人用のファイルが存在する。
 そのため担当者ごとに、注文書番号の前部2文字を識別用にアルファベットで指定している。
 だから、ファイルを変更する場合は、すべての担当者用のファイルを変更しなければならない。
 それを一度に実行するのがメニュー画面の[更新配信]ボタンである。
 通常、注文書作成ファイルは一つの基準ファイルと、複数の担当者用ファイルがあり、どの
 ファイルも同じであるが、プログラムを管理する担当者が基準とするファイルを必要時に変更し、
 そのファイルから担当者用のすべてのファイルを更新する。
既存注文データ検索を参照してください。
抽出結果が表示されて、[注文書番号検索]のフォームが表示される。
これは、注文番号を品名で検索したから、その結果は1行しか表示されないが、その注番には
まだ他に部品があるかもしれないので、[注文書番号検索]で抽出する事により、すべての
部品が注文書に転記される。
[加工部品注文データベース]の[加工DT]シートの[品名]を検索して[mix]を
見つけ出している。
If CheckBox1 = True Then
  Call 部品注番検索    ' CheckBox1 にチェックが付いていたので、
              ' [部品注番検索]を実行する。
If CheckBox1 = False And CheckBox2 = False And CheckBox3 = False Then
  GoTo Jump1     ' CheckBoxのどれもが空白なら Jump1 へジャンプする。
End If
[品名]に mix を入力し、加工部品にチェックを付けて[検索]ボタンを押すと
プログラムを実行する。
●既存注文検索
 [検索]ボタンを押せば実行する。

 Sub 既存注番検索 ( )
   注番検索. Show vbModeless
 End Sub

   
既存注文.TextBox2 = "抽出完了" の様に、フォームの名前を書かなくては動作しない。
と言うことは、複数のフォームを表示させて操作できると言うことである。
尚、フォームを表示させていると、フォーム名は表示されないのでプロパティウインドウ
で見る必要がある。
このコードは、上のフォームの[抽出]ボタンを押した時に実行するものである。
TextBox2に「注番入力せよ」と表示させるものである。これはフォーム内のプログラム
だから、TextBox2と書くだけでよいが、いくらフォームが表示されていると言っても、
他のプログラムではTextBox2と書くだけでは動作しない。
Sheets("加工転送"). Select
Range("Y6:Z13"). Copy
Sheets("部品"). Select
Range("C12:D19").Select
Selection. PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:= False
※ [加工転送]シートのデータを[部品]シートの注文書画面に、値だけ貼り付けている。

●フォームの操作の注意点

加工転送シート右側
strCyu = Worksheets("部品"). Range("W2")    ' プログラムが変わるので注番を取得
Range("B5:Q10000"). Select
Selection. AutoFilter                ' 選択範囲をフィルターする。
ActiveSheet. Range("$B$5:$Q$10000"). AutoFilter Field:=16, Criteria1:= strCyu
Selection. Copy            ' 選択範囲の16列目の注文書番号列を入力注番でフィルタ
                     ' 結果をコピーする。
Range("V5"). Select
ActiveSheet. Paste           ' データベースの右側V5に貼り付ける。
Application. CutCopyMode = False    ' コピーモードを解除
Selection. AutoFilter           ' フィルターを解除
      ' フィルターの解除は ActiveSheet. AutoFilterMode = False でもよい。
※ データベースの V5 にコピーされたフィルター結果を、注文書の[加工転送]シートに転記している
  If TextBox1. Text = "" Then Goto Jump1   ' 注文番号の入力を確認している。
  If CheckBox1 = False And CheckBox2 = False And CheckBox3 = False Then
    Goto Jump2               ' チェック無しを確認する。
  End If
Jump1:
  TextBox2. Text = " 注番入力せよ "       ' 注番の入力を促す。
  Goto JumpEnd
Jump2:
  TextBox2. Text = "選択チェックせよ "      ' 複数チェック付けを確認する。
  Range("W2"). Value = TextBox1. Text      ' 入力された、注番をW2に書いている。
[抽出]ボタンのマクロ
フォームに入力された注文番号を、データベースの中から探し出し、その同じ注番の部品を
注文書に書き出している。
※この[既存注文検索]は、過去に使用した注文番号を入力することによって、その注文データが
 入力画面に呼び出されるシステムである。これによって、過去に注文履歴のあるものは、
 その都度入力しないでも呼び出される。
[無効]ボタンを押せば、[お願い]ボタンが消去する。

●既存注文データ検索
 [注番]ボタンを押せば、
     Sub 既存注文データ取得 ( )
       既存注文. Show vbModeless  ' フォームが開かれる。vbModelessはフォームが出状態で
                       ' 画面移動ができる。
     End Sub
intAsc = Asc(Right(Range"(E8"), 1))     ' 部品シートの E8に入力された製番の右側
                      ' 1ケ目の文字は 2であり、その文字コードの
                      ' 50が intAscに代入される。
If Range("Y1") = 1 Or intAsc > 59 Then Exit Sub
                      ' Y1が 1 か intAsc が 59以上ならプログラム
                      ' が停止される。
 ※文字コードの 59 以上はアルファベットで、修理部品には製番の右端にアルファベット
  一文字が付くので、それが付いている場合は、判定は回避される。
  この製番の場合、[お願い]ボタンで Y1に 1を書いたから、判定は回避される。
  製番そのものには問題が無いので、Y1が 1 で無かったら判定は回避されない。

※Exit Sub はその時点でプログラムの終了であるが、停止するのは[Call 契約一覧の製番と
 対比判定部品] だけであって、その下のメインのプログラムは実行される。

Call 契約一覧製番と対比判定部品
If Worksheets("部品"). Range("X1") = 1 Then Exit Sub
Y1 に 1、X1 に 0 と書かれる。

Sub 契約一覧の製番と対比判定部品
[有効]ボタンを押すと、
ActiveSheets. Unprotect              ' シート保護を解除
ActiveSheets. Shapes("正方形/長方形 40"). Selec   ' ボタンを選択して
Slection. Characters. Text = "お願い"        ' ボタンに "お願い" と書く
Range("A1"). Select
Call 部品お願いボタンにマクロ登録          ' ボタンに[製番判定回避部品]マクロを登録する。
Range("A1").Select
ActiveSheet Protect DrawingObiects:=True, Contents:=True, Scenarios:=Yrue
                           ' シート保護を有効にする。

[お願い]ボタンを押すと、[製番判定回避部品]マクロを実行する。
◆注文書の印刷時に、注文入力した製番を契約一覧の製番と対比判定して、製品が完成して
 いたらその製番で部品を注文できない。
 左の図には、[お願い]ボタンがない。これが普通の状態で、どうしても完成した製番の部品を
 手配しなければならない時に、右図の[有効]ボタンを押すことになる。
  Next
End Sub
' 部品シートの E2 の関数で表示している。
←  = D4 +1

←  =$D$6 & D5
  Range("A1"). Select
  Application. CutCopyMode = False
End If

Windows(MyName). Activate
Sheets("DAT1"). Select          ' 注文書No繰り上げ
Range("D4"). Value = [D4] +1       ' D4 の値 + 1 をD4に書く。
Range("A6:Q" & [R5]). Select   ' A6からQ8を選択する。R5は 8だから
                   ' [R5] はダイレクトに R5の値を指している。
Selection. Copy
Windows("加工部品注文データベース.xlsm"). Activate
Cells(cend + 1, 1). Select      ' cend は86行目である。A列の 86+1 番目の
                  ' セルを選択する。
Selection. PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False   ' 値だけ貼り付け

Windows(MyName). Activate   ' MyNameは注文書作成.xlsm
Sheets("加工転送"). Select
Range("T6:T" & [R5]). Select    ' T6から T8を選択
Selection. Copy
Windows("加工部品注文データベース.xlsm"). Activate
Cells(cend + 1, 20). Select
Selection. PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  *=False, Transpose:=False
Sheets("加工転送"). Select
If Range("R5"). Value > 0 Then     ' R5 は 8である。R5には関数が入っていて
                    ' R6 からR13までの一番大きい値を取得する。
                    ' R8にも関数が入っていて I8が空白でなかったら
                    ' 行番号の 8を入れる。
                    ' R9は I9が空白だから 0が入っている。
Next

Windows("加工部品注文データベース"). Activate
Sheets("加工DT"). Select
Range("B6"). Select
cend = Range("B10000"). End(xlUp). Row
    ' B10000から上に列を調べて最下端のデータのある行番号を cend に代入する。
    ' これは、B6から下へ最下端データ行を調べると、どこかに空白セルがある場合
    ' そこが最下端と認識されるのを防ぐためである。
Windows(MyName). Activate     ' MyNameは注文書作成.xlsmである。
  If K1(1, i2) = 0 Then      ' この部分は通らない。
    K = T(i2) \ D(i2)
  Else
    K = K1(1, i2)
  End If
  N = K
  Sheets("加工転送"). Range("I" & i2 + 5). Value = N
  Sheets("加工転送"). Range("K" & i2 +5).Value = Sheets("加工転送"). _
    Range("I" & i2 + 5) * Sheets("加工転送"). Range("J" & i2 + 5)
End If
※ これは、A1-03 品名 cccc は 6台分で 7ケ注文している、製番は 6ケであるからどれかの
  製番に 1ケ余分に注文することになる。その余分に注文した注番に星マークを付ける。
  データベースに製番別注文として記入したときに、一台分より余分に手配した製番を、
  見つけやすくするためである。

   Sheets("加工転送"). Range("K" & i2 + 5). Value = Sheets("加工転送"). _
     Range("I" & i2 + 5) * Sheets("加工転送"). Range("J" & i2 + 5)
        ' 加工転送の金額列 8行に、加工転送の数量の 2ケ×単価 300の結果を書く。
   T(i2) = T(i2) − N    ' T(3)=5  T(3)は 7で、マイナスN は 2だから 7−2=5
   D(i2) = D(i2) − 1    ' D(3)=5  D(3)は 6で、マイナス 1は 6−1=5
 Else

  
上記に、一旦転記されたすべての数値を、製番一台あたりに分割して行く。

Dim T(1 To 8) As Integer       '数量の入力値 T(1) から T(8) まで変数を使用する。
Dim D(1 To 15) As Integer       ' 製番数 D(1) から D(15) までの変数を使用する。
S = Range("W9")            ' 製番数は 6台 S =6
G = Range("Z11")           ' 注文書の品名行数は 12行から 14行まで 3行入力されているから
                    ' G = 3 になる。
For i = 1 To S              ' 1 から 6 まで
  For i2 = 1 To G          ' 品名データを 1行ずつ順に 3行処理する。
    If i = 1 Then D(i2) = S     ' 最初は i = 1 だから D(1) は 6 になる。
    DT = i2 + 13         ' DT = 1 + 13 だから DT は 14 になる。
    GB = i2 + 11         ' GB = 1 + 11 だから GB は 12 になる。

    If i = 1 Then         ' i = 1 の時だけ
      T1 = Sheets("部品"). Range("G" & GB)   ' T1 = セル G12 の値 数量 6
      T(i2) = T1        ' T(1) は 6 になる。
    End If

    M = T(i2) Mod D(i2)     ' Mod は剰余で余りのことである。
                   ' T(1) は 6 で D(1) は 6 だから、6 ÷ 6 = 1 で余りは 0 である。
                   ' M = 6 Mod 6 M = 0 となる。
     ※ これは製番が 6台なのに、6 で割り切れない数量を入力したときに、余りとして算出される。

    Dim K1(2, 9) As Integer   ' 現在は K1(1, 1) から K1(1, 9) までを使用している。
      If M > 0 Then      ' 余りが 0 より大きい場合。3行目の入力値は 7 で余りが 1 出ている。
        K = T(i2) \ D(i2)    ' K = T(1) ÷ D(1)   \ は整数商で割り切れた数
                   ' K = 7 ÷ 6      K = 1 整数商
                   ' M = 7 Mod 6   M = 1 剰余
        K2 = K         ' K2 = 1      K = 1
        K1(1, i2) = K2    ' K1(1, 3) = 1
        N = K + 1      ' N = 1 + 1 = 2
        Sheets("加工転送"). Range("I" & i2 + 5). Value = N
        Sheets("加工転送"). Range("A" & i2 + 5). Value = "★"   ' 複数製番の時に付く
           ' Sheets("加工転送"). Range("A" & 3 + 5). Value = A列の8行目に星マークが付く。
■加工転送シート画面
単数製番と複数製番の違いは、入力された数量を製番数に分割する処理の違いである。
 For i3 = 6 To 13
   Sheets("加工転送"). Range("Q" & i3). Value = Sheets("部品"). Range("X" & intN)
     ' 一旦入力された数値を、一つの製番で加工転送シートに転記する。
Next
◆Call 複数製番の部品をDBに保存      ' サブマクロの実行
注文書画面の E2 には、='DAT1'!D7 と関数が入っていて、
D7 の注文書No から取得している。
D7 には =$D$6&D5 と関数が入っている。
D5 には = D4 + 1 と関数が入っている。
  Windows(MyName). Activate
  Sheets("DAT1"). Select       ' 注文書No 繰り上げ
  Range("D4"). Value = [D4] + 1   ' [D4] はダイレクトに D4 セルの値を指す。
                     ' だから、D4 = 2008 だから 2008 + 1 = 2009 を
                     ' D4 セルに書く。
End Sub
■加工部品注文データベース. xlsm の[加工DT]シート画面
MyName = ThisWorkbook. Name    ' 現在アクティブなファイル名を MyName に代入する。
                    ' これは、"注文書作成.xlsm" と "加工部品注文データベース.xls"
                    ' を行き来するから基本のファイル名を忘れないようにしている。
intG = Sheets("部品"). Range("Z11")  ' Z11は注文書の数量が入力された行数が入る。

For i = 1 To intG            ' 入力された行データを順に加工転送シートに転記する。
  Sheets("加工転送"). Range("B" & i + 5).Value = Sheets("部品"). Range("E8")
                    ' B6 に製番を記入する。
                    ' 以後、注文番号までを転記する。
Next

Windous("加工部品注文データベース.xlsm"). Activate
Sheets("加工DT"). Select
intRow = Range("B500"). End(xlUp). Row   ' B 列の最終行番号を取得する。

Windows(MyName). Activate         ' "注文書作成.xlsm"に戻る。
Sheets("加工転送"). Select

If Range("R5") > 0 Then           ' "加工転送"シートの R5 は 8 を示しているから
  Range("B6:Q" & [R5]).Select       ' B6 から Q8 を選択して
  Selection. Copy               ' コピーし
  Windous("加工部品注文データベース. xlsm"). Activate
  Cells(intRow + 1, 2). Select        ' 104+1=105 行目の 2 列目に
  Selection.PasteSpecial Paste:= xlPasteValues, Operation:=xlNone, SkipBlanks _
    := False, Transpose:= False      ' 値だけを貼り付ける。
  Windows(MyName). Activate
  Range("A1"). Select
  Application.CutCopyMode = False     ' 貼り付けモードを解除
End If

                                '
■加工転送シート画面
だから、プログラムでは、AA1 が 0 で W9 が 1 なら単製番だと判断している。
---------------------------------------------------------
◆Call 単製番部品をDBに保存      ' サブマクロの実行
入力された製番が、複数か一つかを判定して、データベースに保存するプログラムを
変更している。
一つの製番の場合は、[入力開始]を使用しないで、ダイレクトに入力されることもある。
その場合は、W9 に台数が入らず、W12 にも製番が入らないで AA1 に 0 が入る。
[入力開始]を使用した場合は、W9 に 1 が入り W12 にも製番が入る。
Windows("加工部品c注文データベース.xlsm"). Activate
Sheets("加工DT"). Select
Range("A6:T50"). Delete Shift:= xlUp    ' 削除後に上に詰める。
ActiveWorkbook. Save
Jump:
  Workbooks. Open Filename: = "E:\ 加工部品注文データベース. xlsm"
  With ActiveWorkbook
    strF = . ReadOnly        ' 読み取り専用なら strF にReadOnly を代入する。
    If strF = True Then
      Windows("加工部品注文データベース. xlsm"). Close False
      一時停止 = MsgBox("しばらくお待ちください", vbInformation, "ファイル他で使用中")
                     ' メッセージを表示する。
      PauseTime = 3       ' タイマー3秒
      Start = Timer         ' 経過時間
      Do While Timer < Start + PauseTime   ' Do と Loop の間を3秒間停止する。
      Loop
      Goto Jump                ' 3秒間過ぎると Jump へジャンプする。
    End If
  End Eith
  ActiveSheet. AutoFilterMode = False        ' オートフィルターの解除
  Application.ScreenUpdating = True          ' スクリーン表示移動可能
End Sub

※この動作は、ファイルを開いて、読み取り専用なら3秒待ってファイルを閉じて、再度開いて
 読み取り専用でない場合だけ、加工部品注文データベース.xlsmを開く。

尚、加工部品注文データベース.xlsm を開くと auto_open マクロが起動して、データ行が一定量を
超えていると、上部のデータを長期保存ファイルに移動保存した後に削除する。
自動で保存されるデータベースは、データ量の把握ができないので、収容量を決めておく必要がある。
 
※これは、複数台のPCからデータベースを使用している場合などに、誰かが開いていると
 読み取り専用で開くことになる。それでは書き込みができないので、開いているPCが閉じる
 まで待つことになる。だから、どのPCでもデータベースを使用する場合は、データ検索の時
 には、必要部分をコピーして取得し、書き込むに場合には、書き込む直前に開いて、書き込み
 終了するとすぐに閉じるプログラムにする必要がある。
 他のPCの待機時間を少なくする為である。
   Set myRange = Nothing       ' myRange 経数を開放
  Exit Sub                ' プログラムの終了
End If
--------------------------------------------------------------------
◆Call ファイルが他使用の為待機加工   ' サブマクロの実行

If strKan = "完納" Then     ' 納品コードが [完納] なら
  Worksheets("部品"). Range("X1"). Value = 1
  完成製番警告. Show     ' [完成製番警告]フォームを表示する。
   strSeib = Left(Worksheets("部品"). Range("E8"), 6)
        ' E8 の左から数えて6ケを strSeib に代入している。
        ' E8 に一つの製番が書いてある場合が問題で、複数の製番が書いてある場合は、
        ' その右に書かれている製番は、左の連番だから一番目の製番だけを確認している。
Jump:
   Set myRange = Worksheets("契約一覧"). Range("N" & intG & ":N" & intRow. Find(strSeib)
        ' Range("N8:N27"). Find(A-1234) が契約一覧にあれば、myRange に代入する。
        ' Find 検索の書式である。
   If myRange Is Nothing Then
        ' myRange が空白なら契約一覧に無いということになるので、製番が不良である。
     Worksheets("部品"). Range("X1"). Value = 1
     不良製番警告. Show        ' 不良製番警告フォームを表示する。
     Set myRange = Nothing       ' myRange 変数を開放する。
     Exit Sub              ' チェックプログラムの終了
   End If

   If strSeib <> myRange Then      ' 入力製番と契約一覧の製番の文字列が違う。
     Worksheets("部品"). Range("X1"). Value = 1
     不良製番警告. Show        
     Set myRange = Nothing 
     Exit Sub
   End If

   intGyo = myRange. Row
        ' Set myRange に、Find 検索された製番が代入されたら、その行番号を
        ' intGyo に代入する。
   If strSeib = myRange. Value Then   ' strSeib と myRange が同じなら。
     strKan = Worksheets("契約一覧"). Range("J" & intGyo). Value
        ' 契約一覧のその行の J 列の納品コードを strKan に代入する。
   If strSeib = myRange. Value Then   ' strSeib と myRange が同じなら。
     strKan = Worksheets("契約一覧"). Range("J" & intGyo).Value
        ' 契約一覧のその行の J 列の納品コードを strKan に代入する。
     strCod = Worksheets("契約一覧"). Range("B" & intGyo). Value
        ' 契約一覧のその行の B 列の商品コードを setCod に代入する。
     Worksheets("部品"). Range("AA12"). Value = strCod
        ' その商品コードを部品シートの AA12 に書き込む。
    intRow = Worksheets("契約一覧"). Range("N7"). End(xlDown). Row
          ' 契約一覧の製番列の最下行番号を調べている。
   intG = 8   ' 契約一覧の製番 N 行の初期値

■契約一覧
金額セルに =IF(G12="""","""", G12 * M12) の関数が入っているので数量が空白なら、
金額は空白になる、数量が入っていれば G12×M12 が金額に入る。
これは、[入力消去]ボタンを押した時に、すべてを空白にしたいからである。

-----------------------------------------------------------
◆Call 契約一覧の製番と対比判定部品
If Worksheets("部品").Range("X1") = 1 Then Exit Sub
  ' これは、完成した製番は、契約一覧に[完納]と表示されるで、完納の製番の部品が
  ' 注文されるということは、修理部品かクレーム対応の部品であり、それは修理伝票を
  ' 発行して注文されるはずであるから、完納した製番の部品を不正に注文させない処置を
  ' とっている。但し、完成後にどうしても正規の製番で注文せざるを得ない時には、
  ' 後に説明する[お願いボタン]がある。
尚、G12 の数量にスペースが入っていると、MsgBoxは表示されずに金額セルに
#VALUE! と表示される。
------------------------------------------------------------
◆加工単価記入チェック
  これは、価格を入力しないで注文書を発行しない、と言う規定に基づいたものである。
  ここでは、製番、品名、数量、単価の入力を確認している。
  If Worksheets("部品").Range("E8") = "" Or Worksheets("部品").Ramge("E8") =" " Then
    MsgBox "製番が入力されていない" , vbOKOnly, "製番確認"
    Exit Sub
  End Sub
     ' E8の製番が空白か、又は、スペースが入力されている場合はメッセージを表示する。
  For i = 12 To 19
    Windows(ファイル名).Activate
    If Worksheets("部品").Range("E" & i) <> "" And Worksheets("部品").Range("G" & i) _
     = "" Then
      MsgBox "数量が入力されていない", vbOKOnly, "数量確認"
      Exit Sub
    End If

E12 の品名が空白でなく、G12 の数量が空白なら MsgBox を表示する。
  
ボタンを押すと、[加工品注文書印刷]マクロが実行される。
●複数注番書き出し
 If Range("W9") > 5 And Range("W9") <= 10 THen
      ' これは、W9の製番台数によって、C21の文字数は注番数 5ケ で折り返している。
      ' W9 が 5 より大きくて、W9が 10 か 10 より小さい場合。
  Range("C21"). Value = Range("X12") & "/" & Range("X13") & "/" & Range("X14") & _
    "/" & Range("X15") & "/" Range("X16")
  Range("C22"). Value = Range("X17") & "/" & Range("X18") & "/" & Range("X19") & _
   "/" & Range("X20") & "/" & Range("X21") & "/" & Range("W9") & "台分手配"
 End If
●入力画面に製番を書き込む
 If intdaiC = 0 Then           ' intdaiC = TextSC. Text は3番目テキストで 1240
  Range("strSh2). Value = strTSeib2   ' この場合 0 は適用されない。

 ElseIf intdaiE = 0 Then Range(strSh2). Value = strTSeib2 & strTSeib3
                     ' intdaiE = TextSE. TExt は5番目のテキストは空白
 Else                  ' 3番目のテキストが 0 でないのでここが適用される。
  Range(strSh2). Value = strTSeib2 & TSeib3 & strTSeib4
                ' 部品だから strSh2 = "E8:F9" に
                ' strTSeib2 は A-1234.1235.1236
                 ' strTSeib3 は 1240.1241.1242  strTSeib4 は 空白
                 ' "E8:F9" に A-1234.1235.1236.1240.1241.1242 と書かれる。
 End If
●N = 6 で製番は、6台である。
For i = 1 To N + 1
  Range("W" & 11 + i). Value = strDai2(i)
      ' 初期値は i = 1 だから、strDai2(1) を
      ' Range("W" & 11 + 1) に書き込む。
      ' 順次 W13 行目から下に製番を書き込む。

  If i <> 1 Then strDai2(i) = Right(strDai2(i) , 4)
      ' i が 1 でなかったら、だから i = 2 になった時
      ' strDai2(2) = 1235
      ' これは、製番は A-1235 となっているので
      ' 右から4文字の数値だけを取り出している。

  If i <> 1 Then
      ' 最初だけ発生する。
    strTSeib2 = strDai2(i)
      ' A-1234 をそのまま取り出している。
    GoTo JumpN1
      ' 次のコードを実行しないようにジャンプしている。
  End If
  strTSeib2 = strTSeib2 & "." & strDai2(i)
      ' A-1234 . strDai2(2) = 1235 . strDai2(3) = 1236
      ' の様になる。
JumpN1
  Next
If intdaiB <> 0 Then     ' テキストボックス2に値があれば、テキストボックス1にも値がある
  N = intdaiB − intdaiA   ' はずだから、B から A を減数して台数をNに代入する。
For i = 1 To N         ' 台数が N に代入されたので、1 から台数分を繰り返し
  N2(i + 1) = intdaiA + i  ' はじめの製番に1ずつ増加して製番を配列変数に代入する。
  strDai2(i + 1) = CombKis.Text & N2(i + 1)
Next
  ' Dim strDai2(1 To 20) As String は、strDai2(1) から strDai2(20)まで使用すると宣言している。
  ' Dim strDai2(20) As String と宣言すると、strDai2(0)から strDai2(19)までが変数となる。
●製番が一つしか入っていない時の処理
 If TextSA.Text <> "" And TextSB = "" And TextSC = "" And TextSD = "" And TextSE = "" _
  And TextSF = "" And TextL = "" Then
  Range("strSh2).Value = CombKis.Text & TextSA.Text  ' 製番位置に機種記号と製番を書く。

※ TextSA.Text <> ""      ' これは、空白でない場合。
  TextSB.Text = ""      ' これは、空白の場合
  TextSA.Text = "" Then    ' これは、何々が空白なら、メッセージが表示される。
  If TextSA.Text <> "" Then intdaiA = TextSA. Text   ' テキストボックスが空白で無ければ
  If TextSB.Text <> "" Then intdaiB = TextSB. Text   ' その値を変数に代入する。
If Range("Z1")=1 Then strSh1= "E1"     ' 購入品の仕入先コード書き位置
If Range("Z1")=2 Then strSh1= "E1:F1"  ' 材料の仕入先コード書き位置
 ※購入品、部品、材料では表の形が違うので、Z1に記入されている数値で判断している。

[製番確認 OK] ボタンを押すと、部品シートのAA1セルに1を記入する。
これは、[入力開始]ボタンを使用して製番が入力されたことを証明している。

[入力完了]ボタンを押すと Privete Sub ComEnt_Click が実行される。
[製番確認 OK] ボタン
これが、データベースに書き込まれた製番別のデータである。
製番ごとに、注文番号が付けられ6台分で区切られているのが分かる。
余分に注文した1ケは、前に星マークが付いていて、A1-03の数量2ケになっている。
他は、1台分ずつになっている。余分に注文した、製番も注文番号も星マークで抽出できる。

●では最初に、製番入力フォームの構造を見てゆきましょう
A1-01とA1-02は6台分で入力されているが、A1-03は7ケと記入されている。
何かの都合によって、1ケ余分に注文した場合はどのように処理するのか。
本来、同じ一枚の注文書で注文するのだから、どの製番も同じ数量が原則である。
しかし、どうしても1ケ余分に注文したい時が発生したら、どの様に処理されるのか。
処理されたデータベースの状態を見てみよう。

■加工部品注文データベース.xlsm
仕入先コード、仕入先名、製番、注文書番号が記入されて、「6台分で入力してください」と
注意メッセージが出る。
下方には、製番に対応した注文書番号が記入される。これは、データベースにはそれぞれの製番の
注文書として別々に保存される。だから、後日に製番別に注文部品を調べることができる。
又、入荷の進捗状態も調べることができるようになる。

品番、品名、数量、単価、納入日、製品納期などを担当者が手入力する。
● [入力開始]を押すと製番入力ダイアログが表示される。
  [機種記号]の参照ボタンを押して、表示される機種番号を選択する。
  製番は、一台でも連番でも入力出来て、連番の場合は、前側に初めの番号、右に連番の
  最後の番号を入力する。又、飛び番号になっていて、連番から離れている番号や次の
  別の連番がある場合は2列目や3列目に入力する。
  仕入先コードを入力して、[製番確認OK]を押し、[入力完了]を押す。 
■加工部品注文書作成シート
このシートは、VLOOKUP で仕入先名を取得する為にある。
B列必ず昇順に並んでいる必要がある。

=VLOOKUP(E1,コード!B5:C25,2)
これを、部品シートのE3に記入してある。
E1へ入力の仕入先コード番号によって、仕入先名が表示される。
■コードシート
Dim MyName As Variant       ' MyName という変数は、Book 名だから文字列に
                    ' なるので、Variant で定義する。
MyName=ThisWorkbook.Name     ' これは、今開いているファイル名から
                    ' 仕入先データベース.xlsm に移動するので、今開いている
                    ' ファイル名を変数に代入して、ファイル名を入れなくても
                    ' 元のファイルに戻れるようにしている。
Application.ScreenUpdating=True
Windows(MyName).Active       ' 元のファイル名をアクティブにできる。

ActiveWorkbook.Saved=True     ' 書き込みをしていないから保存しない。
ActiveWorkbook.Close         ' 閉じる。

Application.ScreenUpdating=False
 ' 画面を移動させない

自動仕入先更新の実行
 ' この場合、Call も Run も書いていないが、
 ' サブマクロの実行はされる。
 ' 自分が読みにくいだけである。

Sheets("部品").Select
Range("AA1").Value=0
 ' Range(AA1") に 0 を書いている。
 ' これは初期設定にするためである。

Call 部品お願い消去
 ' [部品お願い消去] サブマクロの実行

それぞれのボタンを押すと、注文書の入力シートに
移動すると同時に、仕入先のデータを更新する。
サブマクロの [契約一覧の製番ソート]では、ソートする行数が分からないので
intRow=Range("C7").End(xlDown).Row で最下行番を調べるが、調べる列のデータに
空白を含まない列を選択することが必要である。空白のある列では End(xlUp) で下から上に
調べる必要がある。
●ファイルを開かないで操作するときには設定が必要になる。
 参照設定が開くと、Microsoft ActiveX Data Objects 2.6 Library にチェックを付ける為に、
 下スクロールで下方へ移動して見つけてチェックを付け、OKを押すと、次に開いたときに上方へ
 移動している。

Eドライブにある、keiyaku.xls ファイルのデータを開かないで取得する構文で、
 Cnn.Provider="Microsoft.ACE.OLEDB.12.0"
 Cnn.Properties("Extended Propertis")="Excel 12.0"
の12.0はExcel 2000 以前は変わる。
 ※データの取得は、この場合 "keiyaku.xls" の商品別シートからすべてのデータを取得して、
  注文書作成の "契約一覧" のA4に貼り付けている。

ファイルの指定方法の構文は、
 Cnn.Open "E" & ":" & "\" & "keiyaku.xls"
のようになるので、注意が必要である。
又取得後に、
 Rec.Close
 Cnn.Close
 Set Rec=Nothing
 Set Cnn=Nothing
を必ず書いて、変数の開放が必要である。
[ツール]の参照設定をクリックする。
' Microsoft ActiveX Data Objects 2.1 Library 以上 2.8は不可
' [ツール] − [参照設定]にてチェックを付ける。
ファイルを開いたときに、[auto open] プログラムを起動する。
1.契約一覧のデータを、Eドライブの keiyaku.xls からファイルを開かないで取得する。
 ※ keiyaku ファイルが xls になっている理由は、弥生販売からの出力データだからである。
2.製番列を昇順にソートして、契約一覧シートに転記する。
■メニュー画面
●このシステムは、注文書兼納品書を作成するものである。
 帳票として、注文書と納品書を兼用して、一枚の帳票で仕入先や外注加工先に、注文時にFAXやメール又は
 手渡して、仕入先や外注加工先からの納品時に、納品書としてこの伝票を品物と一緒に納入する、と言う様に
 帳票への入力を最小限に簡素化したものである。仕入先との折衝は必要であるが。
●又、一度売上の上がった製番の部品を注文しようとすると、警告が出て注文することができない。
 これは、売上が上がった製番の部品を手配するということは、不具合が発生したことを示し、正規の手続きで
 手配されていない。正規なら修理伝票か、不良処理で、別の製番で部品を発注しなければ、原価計算の時に本
 製品と修理部品の区別がつかない。これは、商品の構造的な欠陥が発見された場合などに、不良の原因や追加
 部品の理由などが、担当者の間で不問に付されるのを防ぐ為である。
●又、部品単価が記入されていないと警告が出て注文ができない。
 これは、最安値の価格で発注することを原則としているので、部品単価なしで注文することは、許されない。
 事前に見積もりを取得して注文をすることを原則としている。
●但し、理由のある場合に対応して、自動チェックを無効にする方法も用意されている。
 
実践コース
注文書作成システム


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