FS社向け/製造の記録(pdf等)をExcelから見られるようにした「マクロ製造記録 v0.11」のコード

  1. データブック(xlsx)

    • マクロを起動するボタンを貼り付けておくと、マクロブックを開いていなくても起動することがわかった。

  • マクロブック(xlsm)の更新履歴

§1.Declarations

  1. Option Explicit
  2. Option Compare Binary
  3. Const MDBName As String = "製造記録.mdb"
  4. Const SERVERPath As String = "K:\製造記録"
  5. Const ZUBANFolderName As String = "図面"
  6. Const SHIJIFolderName As String = "指示書"
  7. Const COLZuban As Long = 7     '図番の列番号
  8. Const COLShiji As Long = 9     '指示書の列番号
  9. Const COLWCheck As Long = 10  '重複チェックの列番号
  10. Dim BOOLAns As Boolean
  11. Dim LNGAns As Long
  12. Dim STRAns As String

§2.Sub Auto_Open

  

  1. Sub Auto_Open()
  2. Windows(ThisWorkbook.Name).ActivateNext
  3. End Sub


  • xlsxを開いた後に xlsmを開くと、xlsxの後ろに移動する‥‥ ので、xlsxがアクティブのままになる。
  • Excel 開発者用リファレンス(ヘルプ)によれば、「指定されたウィンドウをアクティブにし、次にそのウィンドウを Z オーダーで一番後ろに移動します」とある。
    1,Zオーダーとは

     ZオーダーはコントロールやWindowの重なりの順番のことです。
    コントロールの前後ろの関係を Zオーダー (Z 順序)という... 

§3.Sub aa_製造記録更新

 

  1. Sub aa_製造記録更新()
  2. Dim mbTitle As String
  3. Dim que As QueryTable
  4. Dim macBookPath As String, macBookName As String
  5. Dim i As Long, LastRow As Long
  6. Dim strSQL As String, strPath As String, strFullPath As String, strPasteTop As String, strExt As String
  7. Dim strZuban As String
  8.  
  9. mbTitle = "製造記録更新/" & ThisWorkbook.Name
  10. Application.ScreenUpdating = False
  11. macBookPath = ThisWorkbook.Path
  12. macBookName = ThisWorkbook.Name
  13. BOOLAns = 作業指図シートのクリア()
  14. Worksheets("作業指図").Select
  15. 'SQL
  16. strSQL = "Select 受付No, 得意先コード, 得意先名, 品名コード, 品名,規格,図番,製造完了日 From D_作業指図" _
  17. & " Where ([受付No] Is Not Null)"
  18. 'QueryTableオブジェクト
  19. Set que = ActiveSheet.QueryTables.Add(Connection:="ODBC;DSN=MS Access Database;DBQ=" _
  20. & macBookPath & "\" & MDBName _
  21. , Destination:=ActiveSheet.Range("A1"), Sql:=strSQL)
  22. 'クエリーを実行し、終わるまで待つ。
  23. que.Refresh (False)   'BackgroundQuery:=False
  24. Set que = Nothing
  25.  
  26. Cells(1, COLShiji) = SHIJIFolderName      'I列のタイトル
  27. Range("A1").Select
  28. LastRow = Selection.End(xlDown).Row   'Ctrl+↓
  29. If LastRow = Rows.Count Then
  30. MsgBox "作業指図の取得に失敗しました。", vbCritical, mbTitle
  31. Exit Sub
  32. End If
  33. For i = 2 To LastRow
  34. '受付No(A列)でファイルを探し、あれば I列にリンクを張る。
  35. strPath = SERVERPath & "\" & SHIJIFolderName & "\" & Cells(i, 1)
  36. '拡張子を strExt にセットする。
  37. STRAns = Dir(strPath & ".*")
  38. If STRAns <> "" Then
  39. strExt = Mid(STRAns, InStrRev(STRAns, ".") + 1)
  40. strFullPath = strPath & "." & strExt
  41. If Dir(strFullPath) = "" Then Stop   '念のため
  42. Cells(i, COLShiji).Select   'I列
  43. ActiveSheet.Hyperlinks.Add Anchor:=Selection _
  44. , Address:=strFullPath, TextToDisplay:=strExt
  45. End If
  46. '図番にリンクを張る。
  47. strZuban = Cells(i, COLZuban)
  48. If Not (strZuban = "" Or strZuban = "**********") Then
  49. strPath = SERVERPath & "\" & ZUBANFolderName & "\" & strZuban
  50. '拡張子を strExt にセットする。
  51. STRAns = Dir(strPath & ".*")
  52. If STRAns <> "" Then
  53. strExt = Mid(STRAns, InStrRev(STRAns, ".") + 1)
  54. strFullPath = strPath & "." & strExt
  55. If Dir(strFullPath) = "" Then Stop   '念のため
  56. Cells(i, COLZuban).Select   'I列
  57. ActiveSheet.Hyperlinks.Add Anchor:=Selection _
  58. , Address:=strFullPath, TextToDisplay:=strZuban
  59. End If
  60. End If
  61. Next
  62.  
  63. 'フィルターを使って、I列が””のレコードを削除する。‥‥ とりあえず中止
  64. '  Range("A1").Select
  65. '  Selection.AutoFilter
  66. '  ActiveSheet.Range("$A$1:$F$" & LastRow).AutoFilter Field:=COLShiji, Criteria1:="="
  67. '  Range("A2").Select
  68. '  Range(Selection, Selection.End(xlDown)).Select
  69. '  Selection.EntireRow.Delete
  70. '  Selection.AutoFilter
  71. '  Range("A1").Select
  72.  
  73. '製造記録 シートに追加する。
  74. Sheets("製造記録").Select
  75. Range("A1").Select
  76. LNGAns = Selection.End(xlDown).Row
  77. If LNGAns >= Rows.Count Then
  78. strPasteTop = "A2"
  79. Else
  80. strPasteTop = "A" & LNGAns + 1
  81. End If
  82.  
  83. Sheets("作業指図").Select
  84. Range("A2").Select
  85. Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
  86. Selection.Copy
  87. Range("A1").Select
  88. Sheets("製造記録").Select
  89. Range(strPasteTop).Select
  90. ActiveSheet.Paste
  91. Range(strPasteTop).Select
  92.  
  93. '受付Noの重複は、下方を優先する。
  94. LastRow = Range("A1").End(xlDown).Row
  95. 'J2に、式 ”=IF(COUNTIF(A2:$A$14,A2)>1,2,1)” を入力し、
  96. Cells(2, COLWCheck).Select
  97. ActiveCell.Formula = "=IF(COUNTIF(A2:$A$" & LastRow & ",A2)>1,2,1)"
  98. 'フィルハンドルを使って、下端までコピーする。
  99. Cells(2, COLWCheck).Select
  100. Selection.AutoFill Destination:=Range(Cells(2, COLWCheck), Cells(LastRow, COLWCheck)), Type:=xlFillDefault
  101. '  Range(Cells(2, COLWCheck), Cells(LastRow, COLWCheck)).Select
  102. 'フィルターをonにし、
  103. Range("A1").Select
  104. Selection.AutoFilter
  105. 'J列が 2 を抽出し削除する。
  106. ActiveSheet.Range(Cells(1, 1), Cells(LastRow, COLWCheck)).AutoFilter Field:=COLWCheck, Criteria1:="2"
  107. LastRow = Range("A1").End(xlDown).Row
  108. Range("A2").Select
  109. Range("A2:A" & LastRow).Select
  110. Selection.EntireRow.Delete
  111. Selection.AutoFilter
  112. Range("A2").Select
  113. '書式設定(汎用性なし...)
  114. Columns("H:H").Select
  115. With Selection
  116. .NumberFormatLocal = "yyyy/mm/dd"
  117. .HorizontalAlignment = xlCenter
  118. End With
  119. Columns("I:I").Select    '中央揃え
  120. With Selection
  121. .HorizontalAlignment = xlCenter
  122. End With
  123. '終了
  124. Application.ScreenUpdating = True
  125. Range("A2").Select
  126. LNGAns = MsgBox("終了しました。" & vbCrLf & vbCrLf _
  127. & "[OK]をクリックすると、製造No.を降順に並べ替えます。", vbInformation + vbOKCancel, mbTitle)
  128. If LNGAns = vbOK Then
  129. ActiveWorkbook.Worksheets("製造記録").Sort.SortFields.Clear
  130. ActiveWorkbook.Worksheets("製造記録").Sort.SortFields.Add Key:=Range("A2:A714"), _
  131. SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  132. With ActiveWorkbook.Worksheets("製造記録").Sort
  133. .SetRange Range("A1:J714")
  134. .Header = xlYes
  135. .MatchCase = False
  136. .Orientation = xlTopToBottom
  137. .SortMethod = xlStroke
  138. .Apply
  139. End With
  140. End If
  141. '作業指図 シートを削除する。
  142. Application.DisplayAlerts = False
  143. Worksheets("作業指図").Delete
  144. Application.DisplayAlerts = True
  145. 'マクロを閉じる
  146. ThisWorkbook.Close (False)
  147. Exit_製造記録更新:
  148. Exit Sub
  149.  
  150. Err_製造記録更新:
  151. MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
  152. Resume Exit_製造記録更新
  153. 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)。
  • No.103〜111 フィルターを使って J列が 2のレコードを削除する。
    1. フィルターをオンにする(No.103〜104)。
    2. J列が 2のレコードを抽出する(No.106)。
    3. 全て選択する(No.107〜109)
    4. 行削除する(No.110)。
    5. オートフィルターを解除する(No.111)。
  • No.114〜122 H列および I列の書式設定

§4.Function 作業指図シートのクリア

  1. Function 作業指図シートのクリア() As Boolean
  2. Dim wks As Worksheet
  3. For Each wks In Worksheets
  4. If wks.Name = "作業指図" Then
  5. Application.DisplayAlerts = False
  6. Worksheets("作業指図").Delete
  7. Application.DisplayAlerts = True
  8. Exit For
  9. End If
  10. Next wks
  11. With Worksheets.Add(After:=Worksheets(Worksheets.Count))
  12. .Name = "作業指図"
  13. End With
  14. Range("A1").Select
  15. 作業指図シートのクリア = True
  16. End Function



「作業指図」という名のシートをクリアするのが目的。

  • 「作業指図」という名のワークシートがあれば削除する。(No.5〜10)
    • Application.DisplayAlerts = False は、削除時の警告を出さないためのコード。
  • 新しいワークシートを最後に作り(追加。No.13)、名前を“作業指図”にする(No.14)。

§5.今後の課題

以下の問題点を含んでいる。

  1. Excelmdbのデータを(SQLで)取り出すのは初めてのことなので、本番の「mdbのコピーを作る」ことを前提にしている。
  2. 基本的には作り置き方式。(過去のデータは xlsxにしかない)
     今回はデモなので、壊れた時等は考慮していない...
  3. 出来た製造記録.xlsx をサーバーに置いても、複数の人が単純に開くと警告が出るはず...
     コピーで開くスイッチは見つけられなかった。