§1.Declarations
- Option Explicit
- Option Compare Binary
- Const MDBName As String = "製造記録.mdb"
- Const SERVERPath As String = "K:\製造記録"
- Const ZUBANFolderName As String = "図面"
- Const SHIJIFolderName As String = "指示書"
- Const COLZuban As Long = 7 '図番の列番号
- Const COLShiji As Long = 9 '指示書の列番号
- Const COLWCheck As Long = 10 '重複チェックの列番号
- Dim BOOLAns As Boolean
- Dim LNGAns As Long
- Dim STRAns As String
§3.Sub aa_製造記録更新
- Sub aa_製造記録更新()
- Dim mbTitle As String
- Dim que As QueryTable
- Dim macBookPath As String, macBookName As String
- Dim i As Long, LastRow As Long
- Dim strSQL As String, strPath As String, strFullPath As String, strPasteTop As String, strExt As String
- Dim strZuban As String
- mbTitle = "製造記録更新/" & ThisWorkbook.Name
- Application.ScreenUpdating = False
- macBookPath = ThisWorkbook.Path
- macBookName = ThisWorkbook.Name
- BOOLAns = 作業指図シートのクリア()
- Worksheets("作業指図").Select
- 'SQL文
- strSQL = "Select 受付No, 得意先コード, 得意先名, 品名コード, 品名,規格,図番,製造完了日 From D_作業指図" _
- & " Where ([受付No] Is Not Null)"
- 'QueryTableオブジェクト
- Set que = ActiveSheet.QueryTables.Add(Connection:="ODBC;DSN=MS Access Database;DBQ=" _
- & macBookPath & "\" & MDBName _
- , Destination:=ActiveSheet.Range("A1"), Sql:=strSQL)
- 'クエリーを実行し、終わるまで待つ。
- que.Refresh (False) 'BackgroundQuery:=False
- Set que = Nothing
- Cells(1, COLShiji) = SHIJIFolderName 'I列のタイトル
- Range("A1").Select
- LastRow = Selection.End(xlDown).Row 'Ctrl+↓
- If LastRow = Rows.Count Then
- MsgBox "作業指図の取得に失敗しました。", vbCritical, mbTitle
- Exit Sub
- End If
- For i = 2 To LastRow
- '受付No(A列)でファイルを探し、あれば I列にリンクを張る。
- strPath = SERVERPath & "\" & SHIJIFolderName & "\" & Cells(i, 1)
- '拡張子を strExt にセットする。
- STRAns = Dir(strPath & ".*")
- If STRAns <> "" Then
- strExt = Mid(STRAns, InStrRev(STRAns, ".") + 1)
- strFullPath = strPath & "." & strExt
- If Dir(strFullPath) = "" Then Stop '念のため
- Cells(i, COLShiji).Select 'I列
- ActiveSheet.Hyperlinks.Add Anchor:=Selection _
- , Address:=strFullPath, TextToDisplay:=strExt
- End If
- '図番にリンクを張る。
- strZuban = Cells(i, COLZuban)
- If Not (strZuban = "" Or strZuban = "**********") Then
- strPath = SERVERPath & "\" & ZUBANFolderName & "\" & strZuban
- '拡張子を strExt にセットする。
- STRAns = Dir(strPath & ".*")
- If STRAns <> "" Then
- strExt = Mid(STRAns, InStrRev(STRAns, ".") + 1)
- strFullPath = strPath & "." & strExt
- If Dir(strFullPath) = "" Then Stop '念のため
- Cells(i, COLZuban).Select 'I列
- ActiveSheet.Hyperlinks.Add Anchor:=Selection _
- , Address:=strFullPath, TextToDisplay:=strZuban
- End If
- End If
- Next
- 'フィルターを使って、I列が””のレコードを削除する。‥‥ とりあえず中止
- ' Range("A1").Select
- ' Selection.AutoFilter
- ' ActiveSheet.Range("$A$1:$F$" & LastRow).AutoFilter Field:=COLShiji, Criteria1:="="
- ' Range("A2").Select
- ' Range(Selection, Selection.End(xlDown)).Select
- ' Selection.EntireRow.Delete
- ' Selection.AutoFilter
- ' Range("A1").Select
- '製造記録 シートに追加する。
- Sheets("製造記録").Select
- Range("A1").Select
- LNGAns = Selection.End(xlDown).Row
- If LNGAns >= Rows.Count Then
- strPasteTop = "A2"
- Else
- strPasteTop = "A" & LNGAns + 1
- End If
- Sheets("作業指図").Select
- Range("A2").Select
- Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
- Selection.Copy
- Range("A1").Select
- Sheets("製造記録").Select
- Range(strPasteTop).Select
- ActiveSheet.Paste
- Range(strPasteTop).Select
- '受付Noの重複は、下方を優先する。
- LastRow = Range("A1").End(xlDown).Row
- 'J2に、式 ”=IF(COUNTIF(A2:$A$14,A2)>1,2,1)” を入力し、
- Cells(2, COLWCheck).Select
- ActiveCell.Formula = "=IF(COUNTIF(A2:$A$" & LastRow & ",A2)>1,2,1)"
- 'フィルハンドルを使って、下端までコピーする。
- Cells(2, COLWCheck).Select
- Selection.AutoFill Destination:=Range(Cells(2, COLWCheck), Cells(LastRow, COLWCheck)), Type:=xlFillDefault
- ' Range(Cells(2, COLWCheck), Cells(LastRow, COLWCheck)).Select
- 'フィルターをonにし、
- Range("A1").Select
- Selection.AutoFilter
- 'J列が 2 を抽出し削除する。
- ActiveSheet.Range(Cells(1, 1), Cells(LastRow, COLWCheck)).AutoFilter Field:=COLWCheck, Criteria1:="2"
- LastRow = Range("A1").End(xlDown).Row
- Range("A2").Select
- Range("A2:A" & LastRow).Select
- Selection.EntireRow.Delete
- Selection.AutoFilter
- Range("A2").Select
- '書式設定(汎用性なし...)
- Columns("H:H").Select
- With Selection
- .NumberFormatLocal = "yyyy/mm/dd"
- .HorizontalAlignment = xlCenter
- End With
- Columns("I:I").Select '中央揃え
- With Selection
- .HorizontalAlignment = xlCenter
- End With
- '終了
- Application.ScreenUpdating = True
- Range("A2").Select
- LNGAns = MsgBox("終了しました。" & vbCrLf & vbCrLf _
- & "[OK]をクリックすると、製造No.を降順に並べ替えます。", vbInformation + vbOKCancel, mbTitle)
- If LNGAns = vbOK Then
- ActiveWorkbook.Worksheets("製造記録").Sort.SortFields.Clear
- ActiveWorkbook.Worksheets("製造記録").Sort.SortFields.Add Key:=Range("A2:A714"), _
- SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
- With ActiveWorkbook.Worksheets("製造記録").Sort
- .SetRange Range("A1:J714")
- .Header = xlYes
- .MatchCase = False
- .Orientation = xlTopToBottom
- .SortMethod = xlStroke
- .Apply
- End With
- End If
- '作業指図 シートを削除する。
- Application.DisplayAlerts = False
- Worksheets("作業指図").Delete
- Application.DisplayAlerts = True
- 'マクロを閉じる
- ThisWorkbook.Close (False)
- Exit_製造記録更新:
- Exit Sub
- Err_製造記録更新:
- MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
- Resume Exit_製造記録更新
- End Sub
- subの名前の“aa_”は、マクロの一覧を表示した時、“Auto_Open”の上(最上部)に出すためで、それ以上の意味は無い。
- No.10 画面の更新を止めるコート。戻すのは No.124。
- No.13 作業指図・シートをクリアする。無ければ作る。
- No.16〜24 SQL文で mdbの作業指図・テーブルから8項目を取り出し、作業指図・シートのセルA1に貼り付ける。
- No.26 I列の項目名を“指示書”にする。
- No.33〜61 「指示書」および「図番」にリンクを張る。
- 指示書フォルダ内に「受付No.*」のファイルを探し(No.37)、あれば、拡張子を取り出し(No.39)、I列に拡張子を入れ、リンクを張る(No.42〜44)。
- 図番については、図番の無いものおよび“**********”は無視し(No.48)、図番フォルダで指示書と同様な操作を行う(No.51〜59)。
- No.63〜71 I列が空のレコードを削除するコードであるが、全て残すことにしたのでコメントアウトした。
- No.74〜81 作業指図を貼り付ける製造記録・シートのセルをセットする。
- No.83〜91 作業指図の全データを選択し、製造記録・シートに貼り付ける。
- No.94〜100 受付Noの重複件数を J列にセットする。
- 関数の基本は“If(CountIf(A2:A1000,A2)>1,2,2)”。
下方にあるものを 1に、上方にあるものは 2にしている。 - 式はフィルハンドルを使ってコピーしている(No.99〜100)。
- 関数の基本は“If(CountIf(A2:A1000,A2)>1,2,2)”。
- No.103〜111 フィルターを使って J列が 2のレコードを削除する。
- フィルターをオンにする(No.103〜104)。
- J列が 2のレコードを抽出する(No.106)。
- 全て選択する(No.107〜109)
- 行削除する(No.110)。
- オートフィルターを解除する(No.111)。
- No.114〜122 H列および I列の書式設定
§4.Function 作業指図シートのクリア
- Function 作業指図シートのクリア() As Boolean
- Dim wks As Worksheet
- For Each wks In Worksheets
- If wks.Name = "作業指図" Then
- Application.DisplayAlerts = False
- Worksheets("作業指図").Delete
- Application.DisplayAlerts = True
- Exit For
- End If
- Next wks
- With Worksheets.Add(After:=Worksheets(Worksheets.Count))
- .Name = "作業指図"
- End With
- Range("A1").Select
- 作業指図シートのクリア = True
- End Function
「作業指図」という名のシートをクリアするのが目的。
- 「作業指図」という名のワークシートがあれば削除する。(No.5〜10)
- Application.DisplayAlerts = False は、削除時の警告を出さないためのコード。
- 新しいワークシートを最後に作り(追加。No.13)、名前を“作業指図”にする(No.14)。