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
　　　　　　　　　　　　　　　　　　　　　' このファイルを同じファイル名で保存する。

●仕入先コード検索

●既存注文検索
　[検索]ボタンを押せば実行する。

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

Sheets("加工転送"). Select
Range("Y6:Z13"). Copy
Sheets("部品"). Select
Range("C12:D19").Select
Selection. PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　:=False, Transpose:= False
※ [加工転送]シートのデータを[部品]シートの注文書画面に、値だけ貼り付けている。

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

※ これは、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
　　

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

　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　'

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 マクロが起動して、データ行が一定量を
超えていると、上部のデータを長期保存ファイルに移動保存した後に削除する。
自動で保存されるデータベースは、データ量の把握ができないので、収容量を決めておく必要がある。　

　　　Set myRange = Nothing　　　　 　　' myRange 経数を開放
　　Exit Sub　　　　　　　 　 　　　　　 ' プログラムの終了
End If
--------------------------------------------------------------------
◆Call ファイルが他使用の為待機加工　　　' サブマクロの実行

　　 　intRow = Worksheets("契約一覧"). Range("N7"). End(xlDown). Row
　　　　　　　　　 ' 契約一覧の製番列の最下行番号を調べている。
　 　intG = 8　　　' 契約一覧の製番 N 行の初期値

■契約一覧

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

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

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

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

　
実践コース
注文書作成システム

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