[無料で構築]スマホで入力、エクセルのアルコールチェック表に出力 | 独学プログラマーHiroのパーツボックスblog

[無料で構築]スマホで入力、エクセルのアルコールチェック表に出力

EXCEL
2022.09.12
スポンサーリンク

重大事故をきっかけに、アルコールチェックが義務化されます。

準備をされている企業も多いのではないでしょうか。

この記事では、紙への手書き入力せずに、スマホから簡単に入力し、提出日に１クリックでエクセルにデータを差し込む方法をお伝えします。

2022年9月現在での推奨される書式への記録を行いますが、法令や記入事項が変更になる場合がありますので、ご注意ください。

用意するもの

  • Googleアカウント
  • Googleフォーム
  • Googleスプレッドシート
  • アルコールチェック記録書式のエクセル（マクロ記述します）
  • 入力用スマホ（Androidを推奨　googleフォームの日付入力が簡単にできるため）

Googleアカウントはすでに用意できている前提で説明させていただきます。

個人用のアカウントでも作ることができますが、離職や配置転換の可能性があることを考えると会社専用のアカウントを作り、運用することをお勧めします。

Googleフォームの設定

Googleドライブに移動し、新規作成をクリックしてGoogleフォームを選択します。

質問する項目を入力します。日付は日付形式、備考は記述式、それ以外はラジオボタンもしくはプルダウンで設定します。備考以外は必須設定にしてください。

各項目の内容は運用に沿った内容に変更してください。

項目設定必須設定
運転者ラジオボタン必須
車両番号ラジオボタン必須
運転前後ラジオボタン必須
日付日付必須
確認方法ラジオボタン必須
検知器の使用ラジオボタン必須
酒気帯びラジオボタン必須
体調等ラジオボタン必須
確認者ラジオボタン必須
備考記述

質問の設定が終わったら右上のプレビュー（目のマーク）を押して動作確認をおこないます。

動作して正常に回答ができたら回答のタブを選択してください。

回答の右上の緑のスプレッドシートを作るボタンを押します。

googleスプレッドシート

スプレッドシートを作成するボタンを押すと確認画面が表示されるので、新しいスプレッドシートを作成を選択して作成を押します。

自動的に回答内容が反映されたスプレッドシートが作られます。

続いてエクセルからデータを取得できるように共有設定をしておきます。

スプレッドシート右上の共有ボタンを押して、リンクを知っている全員に変更して、リンクをコピーを押し、そのあとに完了を押します。

リンクの内容はスプレッドシートのURLになっています。

https://docs.google.com/spreadsheets/d/XXXXXXXXXXXXXXXXX-XXXXXXXXXXXXX-XXXXXXXXXXXXX/edit?usp=sharing

コピーしたリンクは後でエクセルVBAで使用しますので、メモ帳に張り付けておくか、エクセルVBAへの入力時にもう一度リンクをコピーしてください。

アルコールチェック記録表エクセル書式設定

今回は、島根県安全運転者協会のページにある　様式2_酒気帯び確認記録表（記入式）（エクセル）を使用します。

とりあえず入力するセルにある値と図形を削除します。

大かっこの図形が多数あるので、１個選択した後にCtrl+Aで全選択して削除します。

A1セルに「2022/9/1」のように月初の日を入力したら「2022年9月」になるように書式設定をしておきます。

シート名を「チェック表」に変更し、もう一つシートを追加して「データ」に名前を変更します。

変更後、ファイル名を付けて保存するときにマクロを含むことのできる「.XLSM」の拡張子を選択して保存します。

アルコールチェック表にマクロを設定（エクセルVBA)

まずはチェック表シートの印刷する範囲外（T1セルあたり）にマクロを起動するボタンを設置します。

開発タブ内の挿入ボタンを押して、フォームコントロールのボタンを選択して設置します。

開発タブが表示されていない方は下記の記事を参考に表示させてください。

[エクセルVBA]　VBEを開く方法とプログラム起動方法
ExcelVBAを始めるために必要な開発タブの表示とVBエディタの起動方法を説明します。 プログラムのコードを記述する場所や起動方法についての説明もあります。
dokugaku-hiro-partsbox.com
2022.09.06

マクロの保存先は先ほど保存したファイル名を選択して新規作成を押します。

VBE(エディタ）が立ち上がり、チェック表の指定した場所にボタンができますので、右クリックしてテキストの編集をするとボタン表面の文字が変更できます。

続いて、VBE(エディタ）で先ほど新規作成したボタンから実行されるモジュールに下記コードを記述します。（実際にはModule1の内容をすべて削除してから下記コードをコピペします。）

Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, _
     ByVal szURL As String, _
     ByVal szFileName As String, _
     ByVal dwReserved As Long, _
     ByVal lpfnCB As Long) As Long
Sub ボタン1_Click()
  Dim strURL As String
  Dim DROW As Long
  Dim CROW As Long
  Dim TAISHOU As Date
  Dim OBJ1 As Object
  Dim strFile As String
  
  '対象となる年月を取得
  TAISHOU = Worksheets("チェック表").Range("A1").Value
    
  'Googleスプレッドシートの共有リンクを設定
  strURL = "https://docs.google.com/spreadsheets/d/xxxxxxxxxxxxxxxxxxxx/" 'ここを編集
  
  'スプレッドシートのデータをダウンロード
  strFile = GetSpreadsheet(strURL)
  
  '画面更新OFF
  Application.ScreenUpdating = False
  
  'スプレッドシートのデータをデータシートに取り込む
  Call GetSheetDATA(ThisWorkbook, strFile)
    
  'データシートのA列を昇順に並び変える
  With Worksheets("データ")
    DROW = 2
    Do Until .Cells(DROW, 1).Value = ""
    DROW = DROW + 1
    Loop
    DROW = DROW - 1
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending
    .Sort.SetRange .Range("A1:K" & DROW)
    .Sort.Header = xlYes
    .Sort.Apply
  End With
    
  'データシートに取得したデータを書式に流し込む
    
  With Worksheets("チェック表")
    DROW = 2
    .Range("A5:R10000").Clear
    Do Until Worksheets("データ").Cells(DROW, 1).Value = ""
      If Year(TAISHOU) = Year(Worksheets("データ").Cells(DROW, 5).Value) And Month(TAISHOU) = Month(Worksheets("データ").Cells(DROW, 5).Value) Then
        If Worksheets("データ").Cells(DROW, 4).Value = "運転後" Then
          CROW = 5
          Do Until .Cells(CROW, 1).Value = ""
            If .Cells(CROW, 1).Value = Worksheets("データ").Cells(DROW, 2).Value And .Cells(CROW, 2).Value = Worksheets("データ").Cells(DROW, 3).Value Then
              If .Cells(CROW, 3).Value = Worksheets("データ").Cells(DROW, 5).Value Then
                '運転前と運転後合致　運転後に記入する
                If .Cells(CROW, 11).Value = "" Then '複数チェック対応
                  .Cells(CROW, 11).Value = Worksheets("データ").Cells(DROW, 1).Value '確認時間
                  .Cells(CROW, 11).NumberFormatLocal = "h:mm"
                  .Cells(CROW, 12).Value = Worksheets("データ").Cells(DROW, 6).Value '確認方法
                  .Cells(CROW, 13).Value = Worksheets("データ").Cells(DROW, 7).Value '検知器使用
                  .Cells(CROW, 14).Value = Worksheets("データ").Cells(DROW, 8).Value '酒気帯び
                  .Cells(CROW, 15).Value = Worksheets("データ").Cells(DROW, 9).Value '体調等
                  .Cells(CROW, 16).Value = Worksheets("データ").Cells(DROW, 11).Value  '備考
                  .Cells(CROW, 17).Value = Worksheets("データ").Cells(DROW, 10).Value '確認者
                  GoTo NEXTPOINT
                End If
              End If
            End If
            CROW = CROW + 1
          Loop
          '運転前なし
          .Cells(CROW, 1).Value = Worksheets("データ").Cells(DROW, 2).Value '運転者
          .Cells(CROW, 2).Value = Worksheets("データ").Cells(DROW, 3).Value '車両番号
          .Cells(CROW, 3).Value = Worksheets("データ").Cells(DROW, 5).Value '確認年月
          .Cells(CROW, 3).NumberFormatLocal = "M/d"
          .Cells(CROW, 11).Value = Worksheets("データ").Cells(DROW, 1).Value '確認時間
          .Cells(CROW, 11).NumberFormatLocal = "h:mm"
          .Cells(CROW, 12).Value = Worksheets("データ").Cells(DROW, 6).Value '確認方法
          .Cells(CROW, 13).Value = Worksheets("データ").Cells(DROW, 7).Value '検知器使用
          .Cells(CROW, 14).Value = Worksheets("データ").Cells(DROW, 8).Value '酒気帯び
          .Cells(CROW, 15).Value = Worksheets("データ").Cells(DROW, 9).Value '体調等
          .Cells(CROW, 16).Value = Worksheets("データ").Cells(DROW, 11).Value  '備考
          .Cells(CROW, 17).Value = Worksheets("データ").Cells(DROW, 10).Value '確認者
          .Range("A" & CROW & ":R" & CROW).Borders.LineStyle = True
          .Range("A" & CROW & ":R" & CROW).HorizontalAlignment = xlCenter
          .Range("A" & CROW & ":R" & CROW).VerticalAlignment = xlCenter
          .Range("A" & CROW & ":R" & CROW).ShrinkToFit = True
NEXTPOINT:
        Else
          '運転前なので、一番下に追加
          CROW = 5
          Do Until .Cells(CROW, 1).Value = ""
            CROW = CROW + 1
          Loop
          .Cells(CROW, 1).Value = Worksheets("データ").Cells(DROW, 2).Value '運転者
          .Cells(CROW, 2).Value = Worksheets("データ").Cells(DROW, 3).Value '車両番号
          .Cells(CROW, 3).Value = Worksheets("データ").Cells(DROW, 5).Value '確認年月
          .Cells(CROW, 3).NumberFormatLocal = "M/d"
          .Cells(CROW, 4).Value = Worksheets("データ").Cells(DROW, 1).Value '確認時間
          .Cells(CROW, 4).NumberFormatLocal = "h:m"
          .Cells(CROW, 5).Value = Worksheets("データ").Cells(DROW, 6).Value '確認方法
          .Cells(CROW, 6).Value = Worksheets("データ").Cells(DROW, 7).Value '検知器使用
          .Cells(CROW, 7).Value = Worksheets("データ").Cells(DROW, 8).Value '酒気帯び
          .Cells(CROW, 8).Value = Worksheets("データ").Cells(DROW, 9).Value '体調等
          .Cells(CROW, 9).Value = Worksheets("データ").Cells(DROW, 11).Value '備考
          .Cells(CROW, 10).Value = Worksheets("データ").Cells(DROW, 10).Value '確認者
          .Range("A" & CROW & ":R" & CROW).Borders.LineStyle = True
          .Range("A" & CROW & ":R" & CROW).HorizontalAlignment = xlCenter
          .Range("A" & CROW & ":R" & CROW).VerticalAlignment = xlCenter
          .Range("A" & CROW & ":R" & CROW).ShrinkToFit = True
        End If
      End If
      DROW = DROW + 1
    Loop
      
    CROW = 5
    Do Until .Cells(CROW, 1).Value = ""
      CROW = CROW + 1
    Loop
      
    Worksheets("チェック表").PageSetup.PrintArea = "A1:R" & CROW - 1
      
  End With
    
  Application.ScreenUpdating = True
  
  MsgBox "内容を確認して印刷して提出してください"
  'Worksheets("チェック表").PrintPreview

End Sub

'APIのURLDownloadToFileでxlsxをダウンロード
Function GetSpreadsheet(ByVal argURL As String) As String
    Dim outFile As String
    outFile = ThisWorkbook.Path & "\アルコールチェックGS" & Format(Now(), "yyyymmddhhmmss") & ".xlsx"
  
    If argURL Like "*edit?usp=sharing" Then
        argURL = Replace(argURL, "edit?usp=sharing", "")
    End If
    argURL = argURL & "export?format=xlsx"
  
    Call URLDownloadToFile(0, argURL, outFile, 0, 0)
    GetSpreadsheet = outFile
End Function

Sub GetSheetDATA(targetBook As Workbook, ByVal strFile As String)
    'ダウンロードしたxlsxからシートの取込
    Dim wb As Workbook
    Dim WB2 As Workbook
    Dim ws As Worksheet
    
    Set WB2 = ThisWorkbook
    Set wb = Workbooks.Open(Filename:=strFile, ReadOnly:=True)
    
    'データシートをクリア
    WB2.Worksheets("データ").Cells.Clear
    
    For Each ws In wb.Sheets
      If ws.Name = "フォームの回答 1" Then 'Googleスプレッドシートのシート名を入れる
        ws.Cells.Copy WB2.Worksheets("データ").Range("A1")
      End If
    Next
    
    'スプレッドシートのファイルを閉じる
    wb.Close SaveChanges:=False
    
    'ダウンロードしたファイルを削除
    Kill strFile
End Sub

張り付けれたら、goolgeスプレッドシートのリンクを修正します。（edit#以降は削除してください）

strURL = "https://docs.google.com/spreadsheets/d/xxxxxxxxxxxxxxxxxxxx/" 'ここを編集

動作確認

動作確認するためにGoogleフォームで複数のデータを入力しておきましょう。

Googleスプレッドシートを表示すれば内容を確認できます。

アルコールチェック.XLSMに設置したロードボタンを押すとデータがロードされメッセージが表示されます。

もしレコード数が多く、印刷が複数ページにわたる場合には、1から3行をヘッダー行に設定するなどで書式を整えてください。

今回のVBAの仕様

左上の日付（年月）のひと月分のデータを抽出します。

GoogleスプレッドシートのデータをXLSXファイル形式で一時的にアルコールチェック.XLSMと同じフォルダに生成します。（使用後は削除されます）

チェック表シートのデータ入力行はA5からR10000行を想定しています。それ以上になる場合にはプログラムを変更ください。

スプレッドシートのデータを取得後、データシートを並び替えます。Excel2007以降の並び替え方法を使用しています。Excel2007以前のバージョンを使用している場合にはエラーが表示されます。

運転後が日付を超えてた場合にも対応するため、スマホで入力する日付は、運転前の日付にあわせてください。確認時間はタイムスタンプからフォームに入力した時刻がロードされます。

データを印刷する前に確認＆修正できるように印刷プレビューを組み込んでいません。

自動的に印刷プレビューまでおこないたい場合にはprintpreview行を有効にしてください。

行頭の’を削除すれば有効になります。また、一行前のmsgboxの行頭に’を付加すると確認メッセージを表示せずに印刷プレビューになります。

運用にあたり

スマホにgoogleフォームのURLを送付しておきましょう。

スマホ上にリンクを登録しておくとタップするだけで入力できるようになります。

最後に

お疲れさまでした。思うように設定できましたでしょうか？

紙への記入する場合には、各個人用の紙を用意が必要だったりしますよね。

スマホでgoogleフォームへの入力であれば、事前に選択事項を登録しておくだけで選択操作になるので、だいぶ楽になると思います。

今回は対象の期間のレコードすべてをチェック表にロードするようにしました。

会社によっては、運転者ごとのチェック表に出力する必要がある等のケースもあると思います。

これを機会に、エクセルVBAを勉強して改造してみてはいかがでしょうか。

コメント

タイトルとURLをコピーしました