This article is a Private article. Only a writer and users who know the URL can access it.
Please change open range to public in publish setting if you want to share this article with other users.

Excel VBA 長いコードをChatGPT にリファクターしてもらった

Last updated at 2025-05-11Posted at 2025-05-07

料金算出ツールのコードが長すぎる

趣味で開発した、国際郵便の料金を算出するツールです。
種別、名宛国、重量を入力して、かわいいマクロボタンをクリックすると、H5セルに料金が表示されます。EMS、小包、書留の3種類に対応しています。

別シートに種類ごとの料金表があります。


Sub 郵便料金を表示()
  
  Dim Sh_Input As Worksheet: Set Sh_Input = ThisWorkbook.Sheets("入力")

  Dim Sh_EMS As Worksheet: Set Sh_EMS = ThisWorkbook.Sheets("EMS")
  
  Dim Sh_CP As Worksheet: Set Sh_CP = ThisWorkbook.Sheets("CP")
  
  Dim Sh_REG As Worksheet: Set Sh_REG = ThisWorkbook.Sheets("REG")
  
  Dim C_Mail As String: C_Mail = Sh_Input.Range("C5")  '郵便物の種類
  
  Dim country As String: country = Sh_Input.Range("D5") '名宛国
  
  Dim weight As Double: weight = Sh_Input.Range("E5") '重さ
  Dim U_Weight As String: U_Weight = Sh_Input.Range("F5") '重さの単位
  
  Dim Searchcells As Range
  Dim cell As Range
  Dim Country_column As Long, Region_column As Long
  Dim postage As Long
  Dim i As Long
  
  Sh_Input.Range("H5").ClearContents
  Sh_Input.Range("H6").ClearContents
  
  If Sh_Input.Range("F5") = "kg" And Sh_Input.Range("E5") <= 1 Then
      MsgBox "1kgまではg単位で入力してください。", vbInformation
      Exit Sub
  End If
  
  If C_Mail = "EMS" Then 'EMS
    Set Searchcells = Sh_EMS.Range("J4:N69")
    For Each cell In Searchcells
      If cell.Value Like "*" & country & "*" Then
          Country_column = cell.Column 'ここで名宛国に指定した国の列番号が取れる
          Exit For
      End If
    Next cell
    
        If Country_column = 10 Then '第1地帯
            Region_column = 4

            For i = 4 To 9 '500gまで ～ 900gまで 100gずつ増えているゾーン
              If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "g" Then
                  postage = Sh_EMS.Cells(i, Region_column)
                  Sh_Input.Range("H5") = postage
                  Exit For
              End If
            Next i

          For i = 10 To 45 '1.25kgまで ～ 30kgまで
              If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "kg" Then
                  postage = Sh_EMS.Cells(i, Region_column)
                  Sh_Input.Range("H5") = postage
                  Exit For
              End If
            Next i
    
        End If '第1地帯        
        If Country_column = 11 Then '第2地帯
            Region_column = 5

          For i = 4 To 9 '500gまで ～ 900gまで 100gずつ増えているゾーン
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "g" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

        For i = 10 To 45 '1kgまで ～ 30kgまで
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "kg" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

End If '第2地帯

 If Country_column = 12 Then '第3地帯
            Region_column = 6

          For i = 4 To 9 '500gまで ～ 900gまえｄ 100gずつ増えているゾーン
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "g" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

        For i = 10 To 45 '1kgまで ～ 30kgまで
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "kg" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

End If '‘æ4’n‘Ñ

 If Country_column = 13 Then '第4地帯
            Region_column = 7

          For i = 4 To 9 '500gまで ～ 900gまで 100gずつ増えているゾーン
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "g" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

        For i = 10 To 45 '1kgまで ～ 30kgまで
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "kg" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

End If '第4地帯

 If Country_column = 14 Then '第5地帯
            Region_column = 8

          For i = 4 To 9 '500gまで ～ 900gまで 100gずつ増えているゾーン
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "g" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

        For i = 10 To 45 '1kg ‚Ü‚Å ` 30kg‚Ü‚Å
            If 0 < weight And weight <= Sh_EMS.Cells(i, 1) And U_Weight = "kg" Then
                postage = Sh_EMS.Cells(i, Region_column)
                Sh_Input.Range("H5") = postage
                Exit For
            End If
          Next i

  End If '第5地帯

長すぎて全文掲載できませんが、EMSだけでこの量です。保守性0のスパゲッティコードです。

自力で考えたかったけどAIにリファクターしてもらった

コードをそのままペーストして、「短くしてください」と入力したときの回答

ChatGPTが作ったコードを、そのままVBEにペーストして動作確認します。
動かないので、一部（赤枠）修正します。

修正後

EMS/CP（小包）共通処理とありますが、CPを選択すると、CPの料金を表示してくれます。

シート名を可変にして、条件分岐で選択した種類に応じた料金表を参照しています。

修正後の全文

Sub CalculatePostage2()
    Dim wsIn As Worksheet: Set wsIn = ThisWorkbook.Sheets("入力")
    Dim method As String: method = wsIn.Range("C5").Value    '郵送方法
    Dim country As String: country = wsIn.Range("D5").Value '国名
    Dim weight As Double: weight = wsIn.Range("E5").Value    '重量
    Dim unit As String: unit = wsIn.Range("F5").Value      ' 単位
    Dim extraFee As Double: extraFee = 0                      ' 追加料金（書留）

    ' 出力クリア
    wsIn.Range("H5:H6").ClearContents

    ' 重量チェック
    If unit = "kg" And weight <= 1 Then
        MsgBox "1kg以下はg単位で入力してください。", vbInformation
        Exit Sub
    End If

    Select Case UCase(method)
        Case "EMS", "CP"
            Call ProcessStandard(method, country, weight, unit, wsIn)
        Case "REG"
            If Not IsNumeric(wsIn.Range("J5").Value) Then
                MsgBox "J5に数値を入力してください。", vbInformation
                Exit Sub
            End If
            extraFee = wsIn.Range("J5").Value
            wsIn.Range("H6").Value = "書留料金を加算して計算しています。"
            Call ProcessReg(country, weight, unit, extraFee, wsIn)
        Case Else
            MsgBox "C5に種類を入力してください", vbExclamation
    End Select
End Sub

' EMS/CP共通処理
Sub ProcessStandard(method As String, country As String, weight As Double, unit As String, wsIn As Worksheet)
    Dim ws As Worksheet, rng As Range, c As Range
    Set ws = ThisWorkbook.Sheets(method) 'ここでシート名を可変にする
    '↓加筆した箇所
    If method = "EMS" Then
        Set rng = ws.Range("J4:N" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
    End If
    If method = "CP" Then
        Set rng = ws.Range("J4:N" & ws.Cells(ws.Rows.Count, "N").End(xlUp).Row)
    End If
    '↑加筆した箇所
    '国列を検索
    Dim countryCol As Long, regionCol As Long
    For Each c In rng
        If c.Value Like "*" & country & "*" Then
            countryCol = c.Column
            Exit For
        End If
    Next c
    If countryCol = 0 Then
        MsgBox "該当する国が見つかりません。", vbExclamation
        Exit Sub
    End If

    regionCol = countryCol - 6

    ' 運賃取得
    Dim postage As Long
    postage = GetPostage(ws, weight, unit, regionCol)
    wsIn.Range("H5").Value = postage
End Sub

' REG専用処理
Sub ProcessReg(country As String, weight As Double, unit As String, extraFee As Double, wsIn As Worksheet)
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("REG")
    Dim rng As Range, c As Range
    Set rng = ws.Range("J4:N" & ws.Cells(ws.Rows.Count, "N").End(xlUp).Row) '修正箇所

    ' 国列を検索
    Dim countryCol As Long, regionCol As Long
    For Each c In rng
        If c.Value Like "*" & country & "*" Then
            countryCol = c.Column: Exit For
        End If
    Next c
    If countryCol = 0 Then
        MsgBox "該当する国が見つかりません。", vbExclamation
        Exit Sub
    End If
    regionCol = countryCol - 6

    ' 運賃取得 + 書留料金
    Dim postage As Long
    postage = GetPostage(ws, weight, unit, regionCol, True)
    wsIn.Range("H5").Value = postage + extraFee
End Sub

' 運賃取得関数
Function GetPostage(ws As Worksheet, weight As Double, unit As String, regionCol As Long, Optional isReg As Boolean = False) As Long
    Dim i As Long, maxRow As Long, limitCol As Long

    Select Case ws.Name
        Case "EMS"
            limitCol = 1
            If unit = "g" Then
                i = 4: maxRow = 9
            Else
                i = 10: maxRow = 45
            End If
            For i = i To maxRow
                If weight > 0 And weight <= ws.Cells(i, limitCol).Value Then
                    GetPostage = ws.Cells(i, regionCol).Value
                    Exit Function
                End If
            Next i
        Case "CP"
            If unit = "g" Then
                GetPostage = ws.Cells(4, regionCol).Value
            Else
                limitCol = 2
                For i = 5 To 33
                    If weight > 0 And weight <= ws.Cells(i, limitCol).Value Then
                        GetPostage = ws.Cells(i, regionCol).Value
                        Exit Function
                    End If
                Next i
            End If
        Case "REG"
            limitCol = 2
            If unit = "g" Then i = 4: maxRow = 13 Else i = 14: maxRow = 33
            For i = i To maxRow
                If weight > 0 And weight <= ws.Cells(i, limitCol).Value Then
                    GetPostage = ws.Cells(i, regionCol).Value
                    Exit Function
                End If
            Next i
    End Select

    ' 見つからなかった場合は0を返す
    GetPostage = 0
End Function

料金表のシートは、J列からN列にかけて、プログラムで検索するため、地帯別に国名を入力しており、最終行を取得するべき列が郵便物の種類ごとにそれぞれ違っていたため、コードを一部修正・加筆しました。
ChatGPTさんは、この料金表の内容までは知らないはずですが、ここまでのコードを書いてくれるのはすごいですね。

数えてないので正確ではないですが、だいたい3分の1くらいに減りました。

2025.5.11 不具合修正

郵便料金欄に0円が表示される不具合を発見したので、修正しました。

原因
「修正後の全部」308行め
GetPostage = 0
計算結果のすべてが0になるトラップが仕掛けてありました。
これは笑う^^; でもChatGPTのこういうところがかわいい。

    ' 見つからなかった場合は0を返す
    GetPostage = 0
End Function

2025.5.11 再修正

GetPostage = 0 を消しました。

Sub CalculatePostage2()
    Dim wsIn As Worksheet: Set wsIn = ThisWorkbook.Sheets("入力")
    Dim method As String: method = wsIn.Range("C5").Value    '郵送方法
    Dim country As String: country = wsIn.Range("D5").Value '国名
    Dim weight As Double: weight = wsIn.Range("E5").Value    '重量
    Dim unit As String: unit = wsIn.Range("F5").Value      ' 単位
    Dim extraFee As Double: extraFee = 0                      ' 追加料金（書留）

    ' 出力クリア
    wsIn.Range("H5:H6").ClearContents

    ' 重量チェック
    If unit = "kg" And weight <= 1 Then
        MsgBox "1kg以下はg単位で入力してください。", vbInformation
        Exit Sub
    End If

    Select Case UCase(method)
        Case "EMS", "CP"
            Call ProcessStandard(method, country, weight, unit, wsIn)
        Case "REG"
            If Not IsNumeric(wsIn.Range("J5").Value) Then
                MsgBox "J5に数値を入力してください。", vbInformation
                Exit Sub
            End If
            extraFee = wsIn.Range("J5").Value
            wsIn.Range("H6").Value = "書留料金を加算して計算しています。"
            Call ProcessReg(country, weight, unit, extraFee, wsIn)
        Case Else
            MsgBox "C5に種類を入力してください", vbExclamation
    End Select
End Sub

' EMS/CP共通処理
Sub ProcessStandard(method As String, country As String, weight As Double, unit As String, wsIn As Worksheet)
    Dim ws As Worksheet, rng As Range, c As Range
    Set ws = ThisWorkbook.Sheets(method) 'ここでシート名を可変にする
    '↓加筆した箇所
    If method = "EMS" Then
        Set rng = ws.Range("J4:N" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
    End If
    If method = "CP" Then
        Set rng = ws.Range("J4:N" & ws.Cells(ws.Rows.Count, "N").End(xlUp).Row)
    End If
    '↑加筆した箇所
    '国列を検索
    Dim countryCol As Long, regionCol As Long
    For Each c In rng
        If c.Value Like "*" & country & "*" Then
            countryCol = c.Column
            Exit For
        End If
    Next c
    If countryCol = 0 Then
        MsgBox "該当する国が見つかりません。", vbExclamation
        Exit Sub
    End If

    regionCol = countryCol - 6

    ' 運賃取得
    Dim postage As Long
    postage = GetPostage(ws, weight, unit, regionCol)
    wsIn.Range("H5").Value = postage
End Sub

' REG専用処理
Sub ProcessReg(country As String, weight As Double, unit As String, extraFee As Double, wsIn As Worksheet)
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("REG")
    Dim rng As Range, c As Range
    Set rng = ws.Range("J4:N" & ws.Cells(ws.Rows.Count, "N").End(xlUp).Row) '修正箇所

    ' 国列を検索
    Dim countryCol As Long, regionCol As Long
    For Each c In rng
        If c.Value Like "*" & country & "*" Then
            countryCol = c.Column: Exit For
        End If
    Next c
    If countryCol = 0 Then
        MsgBox "該当する国が見つかりません。", vbExclamation
        Exit Sub
    End If
    regionCol = countryCol - 6

    ' 運賃取得 + 書留料金
    Dim postage As Long
    postage = GetPostage(ws, weight, unit, regionCol, True)
    wsIn.Range("H5").Value = postage + extraFee
End Sub

' 運賃取得関数
Function GetPostage(ws As Worksheet, weight As Double, unit As String, regionCol As Long, Optional isReg As Boolean = False) As Long
    Dim i As Long, maxRow As Long, limitCol As Long

    Select Case ws.Name
        Case "EMS"
            limitCol = 1
            If unit = "g" Then
                i = 4: maxRow = 9
            Else
                i = 10: maxRow = 45
            End If
            For i = i To maxRow
                If weight > 0 And weight <= ws.Cells(i, limitCol).Value Then
                    GetPostage = ws.Cells(i, regionCol).Value
                    Exit Function
                End If
            Next i
        Case "CP"
            If unit = "g" Then
                GetPostage = ws.Cells(4, regionCol).Value
            Else
                limitCol = 2
                For i = 5 To 33
                    If weight > 0 And weight <= ws.Cells(i, limitCol).Value Then
                        GetPostage = ws.Cells(i, regionCol).Value
                        Exit Function
                    End If
                Next i
            End If
        Case "REG"
            limitCol = 2
            If unit = "g" Then i = 4: maxRow = 13 Else i = 14: maxRow = 33
            For i = i To maxRow
                If weight > 0 And weight <= ws.Cells(i, limitCol).Value Then
                    GetPostage = ws.Cells(i, regionCol).Value
                    Exit Function
                End If
            Next i
    End Select

End Function

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up