事務処理を効率的に自動化した

2026年6月3日

退職者からの作業引継ぎで、気が付いた

ある1名の退職に伴い、作業の引継ぎをおこないました。
内容を確認して驚きました。
会社の売り上げに関するデータをエクセルに入力しているのですが、同じ情報を何度も違う場所に繰り返し入力しています、入力回数も多く入力した資料をみてさらにべつの資料に入力する始末です。
なんでこんなめんどくさいことを、当たり前のように毎日繰り返しているのだろうと感じました。

受注処理

メールのに添付された見積書を印刷

印刷した見積書に受注日を記入
指定のフォルダに見積書をPDFにて保存
工程表をみて（区分を確認）
印刷した見積書を見ながら指定のExcelシート1に受注日/週/取引先/区分/金額/売上計上/納期/オーダーNoを入力
入力後別の月別シートにまた、納期/受注金額/客先名/オーダーNo/受注日/種別/受注月/入金月/入金予定を入力
月別シートがなければ作成して記入
入金月/入金予定は、各社の検収日一覧から確認して入力
更に別のシート3に客先別に受注日と金額を入力
納品書の作成

納品後

納品後、送付書と見積もり書を照合し注文書とまとめる
注文書に送付日を記入し、送付書に税抜き金額を記入する
確認後、シート4に納品日、取引先/区分/金額/オーダーNoを入力
入力後シート2に発送済みを記載して赤文字にする
シート3に納品日と金額を入力受注金額を確認して赤字にする
工程表でオーダーNoを検索し納入金額を入力し検収日を選択する

この作業に1日数時間とられています

作業を引き継いだが、面倒になったから自動で処理する事にした

自動処理マクロ自動フォルダ作成を作ってみた。

マクロ作成後の手順

受注処理

メールを選択して、見積もり書保存のマクロプログラムボタンを押す

－－－－－－－自動処理－－－－－－－－－－－
メールの文面から、指定フォルダにオーダーNo+客先名のフォルダを作成
作成したフォルダに見積書を保存
メールの内容から受注日/オーダーNo/納期/取引先/区分を読み取り自動フォルダ作成に転記

自動フォルダに転記されたこと確認し、売り上げ高一覧のマクロプログラムボタンを押す。

－－－－－－－自動処理－－－－－－－－－－－
指定のフォルダの中のExcelを開く

書き込み許可のpassワードを入力する

－－－－－－－自動処理－－－－－－－－－－－
シート1を開き受注日/週/取引先/区分/金額/売上計上/納期/オーダーNoを入力
月別シートを開き納期/受注金額/客先名/オーダーNo/受注日/種別/受注月/入金月/入金予定を入力
月別シートがなければ自動で作成

納品書を作成

納品後

納品書と見積もり書を照合しまとめる

シート2を開いて処理をダブルクリック

－－－－－－－自動処理－－－－－－－－－－－
シート2に発送済みを記載して赤文字に変更
シート4にシート4に納品日、取引先/区分/金額/オーダーNoを入力

間違って入力した場合は発送済みをDeleteすればシート4も消えます

マクロ作成後に残った作業

受注処理

メールを選択してボタンを押す
自動フォルダにテータが記載されたことを確認しマクロボタンを押す
Excelパスワードはの入力
納品書作成

納品後

納品書と見積もり書を照合しまとめる
Excelを開いて、納品されたオーダーをダブルクリック
工程表への入力

納品書作成と納品書をまとめる作業以外はマクロボタンを押すだけ

参考にフォルダ作成のマクロのみ公開します。

Sub 見積書フォルダ保管①()

Dim olApp As Object
Dim olSelection As Object
Dim olItem As Object
Dim olAttachment As Object

Dim xlWs As Worksheet
Dim nextRow As Long

Dim mailBody As String

Dim orderNo As String
Dim deliveryDate As String
Dim clientName As String
Dim categoryName As String
Dim totalAmount As Variant
Dim dskAdminNo As String

Dim baseFolderPath As String
Dim parentFolderName As String
Dim targetParentPath As String
Dim newFolderPath As String

Dim tempExcelPath As String
Dim pdfSavePath As String

Dim tempXlApp As Object
Dim tempWb As Object
Dim tempWs As Object

Dim fso As Object

Dim safeFileName As String
Dim safeClientName As String
Dim ext As String

On Error GoTo ERR_HANDLER

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

baseFolderPath = "\\指定のフォルダ\"

Set xlWs = ThisWorkbook.Sheets(1)

On Error Resume Next

Set olApp = GetObject(, "Outlook.Application")

If olApp Is Nothing Then

    MsgBox "Outlookが起動していません。", vbExclamation
    GoTo EXIT_PROC

End If

On Error GoTo ERR_HANDLER

Set olSelection = olApp.ActiveExplorer.Selection

If olSelection.Count = 0 Then

    MsgBox "Outlookでメールを選択してください。", vbExclamation
    GoTo EXIT_PROC

End If

nextRow = xlWs.Cells(xlWs.Rows.Count, 1).End(xlUp).Row + 1

Set fso = CreateObject("Scripting.FileSystemObject")

For Each olItem In olSelection

    If olItem.Class = 43 Then

        totalAmount = ""

        mailBody = olItem.Body

        orderNo = ExtractOrderNoSmart(mailBody)

        ' ====================================
        ' 重複チェック
        ' ====================================
        If orderNo <> "" Then

            If IsOrderNoExists(xlWs, orderNo) Then

                MsgBox "オーダーNo：" & orderNo & _
                       " は既に登録されています。" & vbCrLf & _
                       "スキップします。", vbExclamation

                GoTo NextMail

            End If

        End If

        deliveryDate = CleanDateText(ExtractDataFlexible(mailBody, "納期→"))

        clientName = ExtractClientNameSmart(mailBody)

        categoryName = ExtractCategorySmart(mailBody)

        ' ====================================
        ' 特例変換
        ' ====================================
        If InStr(categoryName, "改造") > 0 Then

            If InStr(UCase(clientName), "AAA") > 0 Then

                clientName = "BBB"

            End If

        End If

        dskAdminNo = ExtractDataFlexible(mailBody, "管理No→")

        ' ====================================
        ' 客先名安全化
        ' ====================================
        safeClientName = clientName

        safeClientName = Replace(safeClientName, "\", "_")
        safeClientName = Replace(safeClientName, "/", "_")
        safeClientName = Replace(safeClientName, ":", "_")
        safeClientName = Replace(safeClientName, "*", "_")
        safeClientName = Replace(safeClientName, "?", "_")
        safeClientName = Replace(safeClientName, """", "_")
        safeClientName = Replace(safeClientName, "<", "_")
        safeClientName = Replace(safeClientName, ">", "_")
        safeClientName = Replace(safeClientName, "|", "_")

        If Len(safeClientName) > 20 Then
            safeClientName = Left(safeClientName, 20)
        End If

        ' ====================================
        ' フォルダ作成
        ' ====================================
        If orderNo <> "" And Len(orderNo) >= 4 Then

            parentFolderName = _
                "20" & Mid(orderNo, 1, 2) & "-" & Mid(orderNo, 3, 2)

            targetParentPath = _
                baseFolderPath & parentFolderName & "\"

            If Dir(targetParentPath, vbDirectory) = "" Then
                MkDir Left(targetParentPath, Len(targetParentPath) - 1)
            End If

            newFolderPath = targetParentPath & _
                            orderNo & "-" & safeClientName

            If Dir(newFolderPath, vbDirectory) = "" Then
                MkDir newFolderPath
            End If

            ' ====================================
            ' 添付ファイル処理
            ' ====================================
            If olItem.Attachments.Count > 0 Then

                For Each olAttachment In olItem.Attachments

                    ext = LCase(Mid(olAttachment.fileName, _
                          InStrRev(olAttachment.fileName, ".")))

                    If ext = ".xls" _
                    Or ext = ".xlsx" _
                    Or ext = ".xlsm" _
                    Or ext = ".xlsb" Then

                        If InStr(olAttachment.fileName, "依頼") = 0 Then

                            safeFileName = olAttachment.fileName

                            safeFileName = Replace(safeFileName, "\", "_")
                            safeFileName = Replace(safeFileName, "/", "_")
                            safeFileName = Replace(safeFileName, ":", "_")
                            safeFileName = Replace(safeFileName, "*", "_")
                            safeFileName = Replace(safeFileName, "?", "_")
                            safeFileName = Replace(safeFileName, """", "_")
                            safeFileName = Replace(safeFileName, "<", "_")
                            safeFileName = Replace(safeFileName, ">", "_")
                            safeFileName = Replace(safeFileName, "|", "_")

                            If Len(safeFileName) > 80 Then
                                safeFileName = Left(safeFileName, 80)
                            End If

                            tempExcelPath = _
                                fso.GetSpecialFolder(2) & "\" & _
                                Format(Now, "yyyymmdd_hhnnss_") & _
                                safeFileName

                            If fso.FileExists(tempExcelPath) Then

                                On Error Resume Next
                                Kill tempExcelPath
                                On Error GoTo ERR_HANDLER

                            End If

                            olAttachment.SaveAsFile tempExcelPath

                            DoEvents
                            Application.Wait Now + TimeValue("0:00:01")

                            Set tempXlApp = CreateObject("Excel.Application")

                            tempXlApp.Visible = False
                            tempXlApp.DisplayAlerts = False

                            Set tempWb = _
                                tempXlApp.Workbooks.Open(tempExcelPath)

                            Set tempWs = tempWb.Sheets(1)

                            totalAmount = _
                                FindGColumnPreviousValue(tempWs)

                            ' ====================================
                            ' PDF保存先
                            ' ====================================
                            pdfSavePath = newFolderPath & "\" & _
          "見積書_" & orderNo & "_" & _
          safeClientName & ".pdf"

                            ' ====================================
                            ' PDF重複チェック
                            ' ====================================
                            If Dir(pdfSavePath) <> "" Then

                                MsgBox "PDFが既に存在するためスキップしました。" _
                                       & vbCrLf & pdfSavePath, vbExclamation

                                GoTo SkipPdfSave

                            End If

                            ' ====================================
                            ' PDF保存
                            ' ====================================
                            On Error Resume Next

                            tempWb.ExportAsFixedFormat _
                                Type:=0, _
                                fileName:=pdfSavePath

                            If Err.Number <> 0 Then

                                MsgBox "PDF保存失敗：" & vbCrLf & _
                                       pdfSavePath, vbExclamation

                                Err.Clear

                            End If

                            On Error GoTo ERR_HANDLER

SkipPdfSave:

                            On Error Resume Next

                            tempWb.Close False
                            tempXlApp.Quit

                            Set tempWs = Nothing
                            Set tempWb = Nothing
                            Set tempXlApp = Nothing

                            On Error GoTo ERR_HANDLER

                            If fso.FileExists(tempExcelPath) Then

                                On Error Resume Next
                                Kill tempExcelPath
                                On Error GoTo 0

                            End If

                        End If

                    End If

                Next olAttachment

            End If

        End If

        ' ====================================
        ' Excel書き込み
        ' ====================================
        xlWs.Cells(nextRow, 1).Value = olItem.ReceivedTime
        xlWs.Cells(nextRow, 2).Value = orderNo
        xlWs.Cells(nextRow, 3).Value = deliveryDate
        xlWs.Cells(nextRow, 4).Value = clientName
        xlWs.Cells(nextRow, 5).Value = categoryName
        xlWs.Cells(nextRow, 6).Value = totalAmount
        xlWs.Cells(nextRow, 7).Value = dskAdminNo

        nextRow = nextRow + 1

    End If

NextMail:

Next olItem

MsgBox "処理が完了しました。", vbInformation

EXIT_PROC:

On Error Resume Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

If Not tempWb Is Nothing Then tempWb.Close False
If Not tempXlApp Is Nothing Then tempXlApp.Quit

Set tempWs = Nothing
Set tempWb = Nothing
Set tempXlApp = Nothing

Set fso = Nothing
Set olSelection = Nothing
Set olApp = Nothing

Exit Sub

ERR_HANDLER:

MsgBox "エラー発生：" & vbCrLf & _
       Err.Number & vbCrLf & _
       Err.Description, vbCritical

Resume EXIT_PROC

End Sub

‘ =====================================================
‘ オーダーNo重複チェック
‘ =====================================================
Function IsOrderNoExists(ws As Worksheet, orderNo As String) As Boolean

Dim lastRow As Long
Dim rng As Range

lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row

If lastRow < 2 Then
    IsOrderNoExists = False
    Exit Function
End If

Set rng = ws.Range("B2:B" & lastRow)

IsOrderNoExists = _
    Application.WorksheetFunction.CountIf(rng, orderNo) > 0

End Function

‘ =====================================================
‘ 客先名取得
‘ =====================================================
Function ExtractClientNameSmart(strSource As String) As String

Dim result As String

result = ExtractByKeyword(strSource, "向けの、")

If result = "" Then result = ExtractByKeyword(strSource, "向け")

If result = "" Then result = ExtractByKeyword(strSource, "から")

ExtractClientNameSmart = result

End Function

‘ =====================================================
‘ キーワード前抽出
‘ =====================================================
Function ExtractByKeyword(strSource As String, keyword As String) As String

Dim endPos As Long
Dim startPos As Long
Dim tempStr As String

endPos = InStr(1, strSource, keyword, vbTextCompare)

If endPos > 0 Then

    tempStr = Left(strSource, endPos - 1)

    startPos = InStrRev(tempStr, vbCrLf)

    If startPos = 0 Then startPos = InStrRev(tempStr, vbLf)
    If startPos = 0 Then startPos = InStrRev(tempStr, vbCr)

    If startPos > 0 Then
        ExtractByKeyword = Trim(Mid(tempStr, startPos + 1))
    Else
        ExtractByKeyword = Trim(tempStr)
    End If

Else

    ExtractByKeyword = ""

End If

End Function

‘ =====================================================
‘ 区分取得
‘ =====================================================
Function ExtractCategorySmart(strSource As String) As String

Dim lines() As String
Dim i As Long

Dim targetLine As String
Dim nextLine As String

Dim result As String
Dim pos As Long

strSource = Replace(strSource, vbCrLf, vbLf)
strSource = Replace(strSource, vbCr, vbLf)

lines = Split(strSource, vbLf)

For i = 0 To UBound(lines)

    If InStr(lines(i), "受注") > 0 Then

        targetLine = Trim(lines(i))

        If i < UBound(lines) Then
            nextLine = Trim(lines(i + 1))
        End If

        Exit For

    End If

Next i

If targetLine = "" Then

    ExtractCategorySmart = ""

    Exit Function

End If

result = targetLine

result = Replace(result, "が受注となりました", "")
result = Replace(result, "が受注なりました", "")
result = Replace(result, "を受注しました", "")
result = Replace(result, "受注決定しました", "")
result = Replace(result, "受注となりました", "")
result = Replace(result, "受注なりました", "")
result = Replace(result, "受注しました", "")

pos = InStr(result, "向けの、")

If pos > 0 Then

    result = Mid(result, pos + 4)

Else

    pos = InStr(result, "向けの")

    If pos > 0 Then

        result = Mid(result, pos + 3)

    Else

        pos = InStr(result, "向け")

        If pos > 0 Then

            result = Mid(result, pos + 2)

        Else

            pos = InStr(result, "から")

            If pos > 0 Then

                result = Mid(result, pos + 2)

            End If

        End If

    End If

End If

If nextLine <> "" Then

    If Left(nextLine, 1) = "（" _
    Or Left(nextLine, 1) = "(" Then

        result = result & " " & nextLine

    End If

End If

result = Replace(result, "　", " ")

Do While InStr(result, "  ") > 0
    result = Replace(result, "  ", " ")
Loop

result = Trim(result)

If Len(result) > 0 Then

    If Left(result, 1) = "の" Then
        result = Mid(result, 2)
    End If

End If

If Len(result) > 0 Then

    If Right(result, 1) = "の" Then
        result = Left(result, Len(result) - 1)
    End If

End If

If Right(result, 1) = "。" Then
    result = Left(result, Len(result) - 1)
End If

If Right(result, 1) = "." Then
    result = Left(result, Len(result) - 1)
End If

ExtractCategorySmart = Trim(result)

End Function

‘ =====================================================
‘ G列最終行1つ前取得
‘ =====================================================
Function FindGColumnPreviousValue(ws As Object) As Variant

Dim lastRow As Long
Dim targetRow As Long
Dim cellVal As Variant

On Error Resume Next

lastRow = ws.Cells(ws.Rows.Count, 7).End(xlUp).Row

If lastRow > 1 Then

    targetRow = lastRow - 1

    cellVal = ws.Cells(targetRow, 7).Value

    If IsNumeric(cellVal) And cellVal <> "" Then

        FindGColumnPreviousValue = CDbl(cellVal)
        Exit Function

    End If

End If

On Error GoTo 0

FindGColumnPreviousValue = ""

End Function

‘ =====================================================
‘ 日付整形
‘ =====================================================
Function CleanDateText(rawText As String) As String

Dim i As Long
Dim char As String
Dim cleanStr As String

cleanStr = ""

For i = 1 To Len(rawText)

    char = Mid(rawText, i, 1)

    If char Like "[0-9]" _
    Or char Like "[０-９]" _
    Or char = "/" _
    Or char = "." _
    Or char = "-" _
    Or char = "年" _
    Or char = "月" _
    Or char = "日" Then

        cleanStr = cleanStr & char

    Else

        If Len(cleanStr) > 0 Then Exit For

    End If

Next i

cleanStr = StrConv(cleanStr, vbNarrow)

cleanStr = Replace(cleanStr, "年", "/")
cleanStr = Replace(cleanStr, "月", "/")

If Right(cleanStr, 1) = "/" Then
    cleanStr = Left(cleanStr, Len(cleanStr) - 1)
End If

CleanDateText = Trim(cleanStr)

End Function

‘ =====================================================
‘ オーダーNo抽出
‘ =====================================================
Function ExtractOrderNoSmart(strSource As String) As String

Dim startPos As Long
Dim arrowPos As Long
Dim endPos As Long

Dim tempStr As String

startPos = InStr(1, strSource, "オーダー", vbTextCompare)

If startPos = 0 Then

    ExtractOrderNoSmart = ""
    Exit Function

End If

arrowPos = InStr(startPos, strSource, "→")

If arrowPos = 0 Then
    arrowPos = InStr(startPos, strSource, "->")
End If

If arrowPos > 0 Then

    tempStr = Mid(strSource, arrowPos + 1)

    Do While Left(tempStr, 1) = " " _
       Or Left(tempStr, 1) = "　"

        tempStr = Mid(tempStr, 2)

    Loop

    endPos = InStr(tempStr, vbCrLf)

    If endPos = 0 Then endPos = InStr(tempStr, vbLf)
    If endPos = 0 Then endPos = InStr(tempStr, vbCr)

    If endPos > 0 Then
        ExtractOrderNoSmart = Trim(Left(tempStr, endPos - 1))
    Else
        ExtractOrderNoSmart = Trim(tempStr)
    End If

Else

    ExtractOrderNoSmart = ""

End If

End Function

‘ =====================================================
‘ データ抽出
‘ =====================================================
Function ExtractDataFlexible(strSource As String, keyword As String) As String

Dim startPos As Long
Dim endPos As Long

Dim tempStr As String

startPos = InStr(1, strSource, keyword, vbTextCompare)

If startPos = 0 Then

    ExtractDataFlexible = ""
    Exit Function

End If

startPos = startPos + Len(keyword)

tempStr = Mid(strSource, startPos)

Do While Left(tempStr, 1) = " " _
   Or Left(tempStr, 1) = "　"

    tempStr = Mid(tempStr, 2)

Loop

endPos = InStr(tempStr, vbCrLf)

If endPos = 0 Then endPos = InStr(tempStr, vbLf)
If endPos = 0 Then endPos = InStr(tempStr, vbCr)

If endPos > 0 Then
    ExtractDataFlexible = Trim(Left(tempStr, endPos - 1))
Else
    ExtractDataFlexible = Trim(tempStr)
End If

End Function

かなり複雑に制約はしましたが作成日数2日作業の合間です。

作業短縮は1オーター20分程度です月50オーダーで17時間、年間204時間の削減です
1人が1ヶ月半働く必要があります

久ブリの投稿になりますが
これからも効率化の情報を展開したいとおもいます。

よかったらシェアしてね！

URLをコピーしました！

URLをコピーしました！

金型設計者が考慮すべきポイント

この記事を書いた人

jene 技術部長

2人の娘を育てる父親のjeneです。
2人の娘と一緒に勉強しています。
週末は娘の好きなごはんを一生懸命に作るけなげなPaPaです。
金型設計責任者をしながら、VABマクロで作業効率化を業務として改善活動に行っています。
コロナ前には県の作業効率化のAI事業案件に採択されて独自AIを作ったこともあります。

事務処理を効率的に自動化した

受注処理

納品後

自動処理マクロ自動フォルダ作成を作ってみた。

受注処理

納品後

マクロ作成後に残った作業

受注処理

納品後

この記事を書いた人

コメント

コメントするコメントをキャンセル

事務処理を効率的に自動化した

受注処理

納品後

自動処理マクロ自動フォルダ作成を作ってみた。

受注処理

納品後

マクロ作成後に残った作業

受注処理

納品後

この記事を書いた人

関連記事

コメント

コメントする コメントをキャンセル

コメントするコメントをキャンセル