[[20190118163017]] 『自動計算する列を追加したい』(ぽんくら) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『自動計算する列を追加したい』(ぽんくら)

VBA初心者です。

業務で使用しているエクセルファイルに、K列に商品型番、L列に台数を入力すると、AE列に商品金額×台数が自動計算され自動入力されるマクロが書き込まれています(Sheet1)。
このファイルに2列(N列=受注台数、AF列=計上金額)追加し、受注台数を入力すると計上金額が自動で計算・同じ行に入力されるようにコードを追加したいのですが、K・L列に設定されたコードをコピペし、見よう見まねで書き換えてみても自動計算はされませんでした。

どこをどう書き換えれば良いのかご教授いただけないでしょうか?

シートに記載されている情報と従来のコード、自分で追加・書き換えをしたコードをそれぞれ以下に記載します。

・商品型番と商品金額の一覧はSheet2に記載されています。
・Sheet3に列情報が記載されています。
・マクロはModule1と、Sheet1に書かれています。

<Sheet3の内容>

シート名 Sheet1 SHEET_NAME_MISSION_LIST
列範囲 A5:AG6

明細開始行 7 行 ROW_MISSION_LIST_SHEET_DETAIL_START

列情報
"本体/オプション
商品型番" 11 列 COL_MISSION_LIST_SHEET_GOODS_CODE
"台数履歴
○台→○台" 12 列 COL_MISSION_LIST_SHEET_BODY_COUNT
"受注
台数" 14 列 COL_MISSION_LIST_SHEET_BODY_COUNT_CONTRACT  ←追加列
"合計金額
(自動計算)" 31 列 COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT
"計上金額
(自動計算)" 32 列 COL_MISSION_LIST_SHEET_CONTRACT_ADD_UP ←追加列

シート名  Sheet2  SHEET_NAME_DROPDOWN
列範囲 A5:AD5

明細開始行 6 行 ROW_DROPDOWN_SHEET_DETAIL_START

列情報
"本体/オプション
商品型番" 9 列 COL_DROPDOWN_SHEET_GOODS_CODE
商品金額  10 列 COL_DROPDOWN_SHEET_COST

/////////////////////////////////////////

<Module1のコード>
Option Explicit

Public Const SHEET_NAME_CONST = "定数"

Public SHEET_NAME_MISSION_LIST As String
Public ROW_MISSION_LIST_SHEET_DETAIL_START As Long
Public COL_MISSION_LIST_SHEET_GOODS_CODE As Long
Public COL_MISSION_LIST_SHEET_BODY_COUNT As Long
Public COL_MISSION_LIST_SHEET_BODY_COUNT_CONTRACT As Long '受注台数
Public COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT As Long
Public COL_MISSION_LIST_SHEET_CONTRACT_ADD_UP As Long '計上金額

Public SHEET_NAME_DROPDOWN As String
Public ROW_DROPDOWN_SHEET_DETAIL_START As Long
Public COL_DROPDOWN_SHEET_GOODS_CODE As Long
Public COL_DROPDOWN_SHEET_COST As Long

Public Type CellInfo

    Value                       As String
End Type

Public Type GoodsInfo

    Code                        As String
    Cost                        As Long
End Type
Public GoodsInfos()             As GoodsInfo

/////////////////////////////////////////

<sheet1のコード>

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim row         As Long
    Dim col         As Long

    On Error GoTo Worksheet_Change_Err

    row = Target.row     
    col = Target.Column  

    If row >= ROW_MISSION_LIST_SHEET_DETAIL_START Then

        Select Case col
            Case COL_MISSION_LIST_SHEET_BODY_COUNT

                ' 合計金額セットアップ
                If SetupContractAmount(row) = False Then GoTo Worksheet_Change_End

                ' 計上金額セットアップ
                If SetupContractAddUp(row) = False Then GoTo Worksheet_Change_End

            Case COL_MISSION_LIST_SHEET_GOODS_CODE
                ' 合計金額セットアップ
                If SetupContractAmount(row) = False Then GoTo Worksheet_Change_End

                ' 計上金額セットアップ
                If SetupContractAddUp(row) = False Then GoTo Worksheet_Change_End

        End Select

    End If

Worksheet_Change_End:

    Exit Sub

Worksheet_Change_Err:

    MethodName = SHEET_NAME_MISSION_LIST & " Worksheet_Change"
    Call DispErr(Err.Number, Err.Description)
    Resume Worksheet_Change_End

End Sub
〜〜〜〜〜〜〜〜

Private Function SplitCellValue(ByVal row As Long, ByVal col As Long, ByRef rtnValues() As String, _

                                Optional ByVal bNum As Boolean = False) As Boolean
    Dim tmpValues()     As String
    Dim str             As String

    Dim i               As Long
    Dim k               As Long
    Dim m               As Long

    SplitCellValue = False

    On Error GoTo SplitCellValue_Err

    ' 改行で分割
    rtnValues = Split(Cells(row, col).Value, vbLf)
    ' 取り消し線の文字を削除
    k = 0
    For i = 0 To UBound(rtnValues)
        str = Empty
        For m = 1 To Len(rtnValues(i))
            If Cells(row, COL_MISSION_LIST_SHEET_BODY_COUNT).Characters(Start:=k + m, Length:=1).Font.Strikethrough Then
            Else
                str = str & Mid(rtnValues(i), m, 1)
            End If
        Next m
        rtnValues(i) = str
        k = k + Len(rtnValues(i)) + 1
    Next i

    ' 矢印文字がある場合、最新のもののみを対象
    For i = 0 To UBound(rtnValues)
        If InStr(1, rtnValues(i), "→") > 0 Then
            tmpValues = Split(rtnValues(i), "→")
            rtnValues(i) = tmpValues(UBound(tmpValues))
        End If
        If InStr(1, rtnValues(i), "←") > 0 Then
            tmpValues = Split(rtnValues(i), "←")
            rtnValues(i) = tmpValues(0)
        End If
        If bNum = True Then
            str = Empty
            For m = 1 To Len(rtnValues(i))
                If LenB(StrConv(Mid(rtnValues(i), m, 1), vbFromUnicode)) = 1 Then  ' 1バイト(半角)文字のみ対象
                    If IsNumeric(Mid(rtnValues(i), m, 1)) Then
                        str = str & Mid(rtnValues(i), m, 1)
                    End If
                End If
            Next m
            If str = Empty Then str = "0"
            rtnValues(i) = str
        End If
    Next i

    SplitCellValue = True

SplitCellValue_End:

    Exit Function

SplitCellValue_Err:

    MethodName = SHEET_NAME_MISSION_LIST & " SplitCellValue"
    Call DispErr(Err.Number, Err.Description)
    Resume SplitCellValue_End

End Function
〜〜〜〜〜〜

Private Function SetupContractAmount(ByVal row As Long) As Boolean

    Dim GoodsCodes()        As String
    Dim BodyCounts()        As String
    Dim str         As String

    Dim i           As Long
    Dim k           As Long
    Dim m           As Long

    Dim lRet        As Long

    SetupContractAmount = False

    On Error GoTo SetupContractAmount_Err

    If SplitCellValue(row, COL_MISSION_LIST_SHEET_GOODS_CODE, GoodsCodes) = False Then GoTo SetupContractAmount_End
    If SplitCellValue(row, COL_MISSION_LIST_SHEET_BODY_COUNT, BodyCounts, True) = False Then GoTo SetupContractAmount_End

    ' 商品型番の個数と台数の個数が一致しているかチェック
    If Not Not GoodsCodes Then
    Else
        Call DispLog("本体商品型番が入力されていません。")
        GoTo SetupContractAmount_999
    End If
    If Not Not BodyCounts Then
    Else
        Call DispLog("本体台数が入力されていません。")
        GoTo SetupContractAmount_999
    End If
    If UBound(GoodsCodes) <> UBound(BodyCounts) Then
        Call DispLog("本体商品型番[" & UBound(GoodsCodes) + 1 & _
                     "個]と本体台数[" & UBound(BodyCounts) + 1 & "個]の個数が一致していません。")
        GoTo SetupContractAmount_999
    End If

    ' 合計金額算出
    lRet = 0
    Cells(row, COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT).Value = lRet
    For i = 0 To UBound(GoodsCodes)
        For m = 0 To UBound(GoodsInfos)
            If GoodsInfos(m).Code = GoodsCodes(i) Then

                lRet = lRet + BodyCounts(i) * GoodsInfos(m).Cost

                Exit For

            End If
        Next m
        If m > UBound(GoodsInfos) Then
            Call DispLog("本体商品型番[" & GoodsCodes(i) & _
                         "]に該当するものが" & SHEET_NAME_DROPDOWN & "シートに見つかりません。")

            GoTo SetupContractAmount_End
        End If

    Next i

    Cells(row, COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT).Value = lRet

SetupContractAmount_999:

    SetupContractAmount = True

SetupContractAmount_End:

    Exit Function

SetupContractAmount_Err:

    MethodName = SHEET_NAME_MISSION_LIST & " SetupContractAmount"
    Call DispErr(Err.Number, Err.Description)
    Resume SetupContractAmount_End

End Function
〜〜〜〜〜

’以下自分で追加・変数名を書き換えたコード

Private Function SetupContractAddUp(ByVal row As Long) As Boolean

    Dim GoodsCodes()        As String
    Dim BodyCounts()        As String
    Dim str         As String

    Dim i           As Long
    Dim k           As Long
    Dim m           As Long

    Dim lRet        As Long

    SetupContractAddUp = False

    On Error GoTo SetupContractAddUp_Err

    If SplitCellValue(row, COL_MISSION_LIST_SHEET_GOODS_CODE, GoodsCodes) = False Then GoTo SetupContractAddUp_End
    If SplitCellValue(row, COL_MISSION_LIST_SHEET_BODY_COUNT_CONTRACT, BodyCounts, True) = False Then GoTo SetupContractAddUp_End

    ' 商品型番の個数と台数の個数が一致しているかチェック
    If Not Not GoodsCodes Then
    Else
        Call DispLog("本体商品型番が入力されていません。")
        GoTo SetupContractAddUp_999
    End If
    If Not Not BodyCounts Then
    Else
        Call DispLog("本体台数が入力されていません。")
        GoTo SetupContractAddUp_999
    End If
    If UBound(GoodsCodes) <> UBound(BodyCounts) Then
        Call DispLog("本体商品型番[" & UBound(GoodsCodes) + 1 & _
                     "個]と本体台数[" & UBound(BodyCounts) + 1 & "個]の個数が一致していません。")
        GoTo SetupContractAddUp_999
    End If

    ' 計上金額算出
    lRet = 0
    Cells(row, COL_MISSION_LIST_SHEET_CONTRACT_ADD_UP).Value = lRet  
    For i = 0 To UBound(GoodsCodes)                                  
        For m = 0 To UBound(GoodsInfos)
            If GoodsInfos(m).Code = GoodsCodes(i) Then

                lRet = lRet + BodyCounts(i) * GoodsInfos(m).Cost

                Exit For

            End If
        Next m
        If m > UBound(GoodsInfos) Then
            Call DispLog("本体商品型番[" & GoodsCodes(i) & _
                         "]に該当するものが" & SHEET_NAME_DROPDOWN & "シートに見つかりません。")

            GoTo SetupContractAddUp_End
        End If

    Next i

    Cells(row, COL_MISSION_LIST_SHEET_CONTRACT_ADD_UP).Value = lRet

SetupContractAddUp_999:

    SetupContractAddUp = True

SetupContractAddUp_End:

    Exit Function

SetupContractAddUp_Err:

    MethodName = SHEET_NAME_MISSION_LIST & " SetupContractAddUp"
    Call DispErr(Err.Number, Err.Description)
    Resume SetupContractAddUp_End

End Function

< 使用 Excel:Excel2013、使用 OS:Windows10 >


 回答じゃなく、純粋な疑問なんですが
 >受注台数を入力すると計上金額が自動で計算
 は、計算式ではダメなんですか?
 AE1=VLOOKUP(K1,Sheet2!商品品番・価格の列,2,0)*L1
 てな具合で出せそうな気がしますけど。

 もしよければ、下のコードで、現在の表がどうなっているのか教えていただけますか?
 実行するとクリップボードに表っぽいのが保存されますので、あとはここに張り付けてもらえればOKです。
 あまり広い範囲だとあれなんで、数サンプル分わかればOKです。
    Sub ■説明用の表作成()
        c = Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", " ")
        rc = Split(Application.InputBox(prompt:="行-列の書式で作成したい表範囲を選択してください"), "-")
        If Not UBound(rc, 1) = 1 Then Exit Sub
        For i = 1 To rc(0)
            Selection.Offset(i) = "[" & i & "]"
        Next
        For j = 1 To rc(1)
            Selection.Offset(, j) = "[" & c(j - 1) & "]"
        Next
    End Sub

(稲葉) 2019/01/18(金) 18:46


 すみません、↑のコード無視してください。
[[20110209184943]] 『[談]シートレイアウトの投稿どうしてますか?』(momo)
 リンク先のコード使ってください。
(稲葉) 2019/01/18(金) 18:49

稲葉さん
コメントありがとうございます!

>計算式ではダメなんですか?
毎日10行以上のデータが追加され複数人が触るので、表が崩れないように、できれば合計金額と同じようにマクロでやりたいなと思っていました。。

現在の表については、週明けに投稿させていただきます!
(ぽんくら) 2019/01/19(土) 00:43


 >表が崩れないように
 であれば、計算式にして、シートの保護をおすすめします

 私は、その理由であればコード書きません

 というか、作った人に問い合わせできないのですか?
(稲葉) 2019/01/19(土) 05:43

稲葉さんご返信ありがとうございます!
やっぱり計算式のほうが手間なくできますよね、、、計算式でも一度作成してみようと思います!ありがとうございます。
作った方には連絡が取れず、どのようにコードを変更すればよいのか純粋に疑問だったのでこちらで質問させていただきました。

あと、一応教えていただいたコード実行してみましたが、列範囲が広くて表が崩れてしまったのでマクロに必要な列のみ手打ちしてみました。
N列とAF列が今回追加したい列です。

    |[G]  |[J]       |[K] |[L]    |[M]   |[N]   |[V]    |[AB]    |[AE]       |[AF]
 [5]|お客様|出荷予定 |型番 |台数履歴 |台数  |受注台数|販売店 |支社  |合計金額  |計上金額 

 [10]|A産業|2019年2月|商品A|2        |2     |      |A社    |四国支社|\120,000   |    
 [11]|D商店|2019年4月|商品B|25       |25    |        |B社    |北陸支社|\3,000,000 |    
 [12]|B商店|2019年1月|商品C|1        |1     |      |B社    |関東支社|\10,000    |    
 [13]|C食品|2019年2月|商品C|100      |100   |       |C社    |東北支社|\1,000,000 |    

(ぽんくら) 2019/01/21(月) 10:55


 コード全部見てきましたけど、結局わかりません。

 1)標準モジュールに書かれた変数を定義するコードがありませんが、
   ThisWorkbookモジュールのWorkbook_Openイベントに何かありませんか?

 2)Cells(row, COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT).Value = lRet
   の部分でセルに書き込んでいますが、なぜFunctionモジュールで・・・?

 3)lRet = lRet + BodyCounts(i) * GoodsInfos(m).Cost
   ここで書き込む金額を計算していますが、GoodsInfos(m)の配列がどこから引っ張って
   どのような値が入っているかわからないので、「どこを直す」の問いに答えようがありません。

 4)Call DispErrのプロシージャを呼んでますが、どこにあるの?

 表も見させてもらいましたけど、台数と受注台数の違い、合計金額と計上金額の違いが判りません。

 私個人の感想ですが、今あるプログラムも全部破棄して、計算式で作り変えたほうがよっぽどいいと思います。

(稲葉) 2019/01/21(月) 12:24


稲葉さん
ThisWorkbookモジュールのコードを見落としてました、申し訳ありません。↓に記載します。

Call DispErrについては、エラーのログが表示されるシート(シート名:ログ)があり、このエラーを自動表示するため、標準モジュール(Module2)に別にコードが組まれています。自動計算とは関係がないと思い、投稿しませんでした。重ね重ねすみません。念のため、ThisWorkbookモジュールのコードの下に記載します。

台数と受注台数の違い
→台数は受注予定の商品台数が入力され、受注台数は実際の受注数が入力されます。

合計金額と計上金額の違い
→合計金額は受注予定台数の商品金額合計です。計上金額は受注台数の合計金額です。

あと、最初の投稿で列情報が記載されているのはシート名:Sheet3と記載していましたが、正しくは”定数”
でした。

説明不足とコードの記載不足がありすみません、、、、

以下コードを記載いたします。

<ThisWorkbook>

Option Explicit

Private Sub Workbook_Open()

    On Error GoTo Workbook_Open_Err

    ' ログ初期化
    If InitLog = False Then GoTo Workbook_Open_Err

    ' Sheet2情報取り込み
    If ConstSheetValueToConst() = False Then GoTo Workbook_Open_End

Workbook_Open_End:

    Exit Sub

Workbook_Open_Err:

    MethodName = "Workbook_Open"
    Call DispErr(Err.Number, Err.Description)
    GoTo Workbook_Open_End

End Sub

Private Function ConstSheetValueToConst() As Boolean

    Dim row As Long, col As Long
    Dim cellInfos As Variant
    Dim i As Long
    Dim m As Long

    ConstSheetValueToConst = False

    On Error GoTo ConstSheetValueToConst_Err

    ' 定数シート(元Sheet3)から取得
    With ThisWorkbook.Worksheets(SHEET_NAME_CONST)

        ' Sheet1********************************************************
        ' シート名
        FindName = "SHEET_NAME_MISSION_LIST"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        SHEET_NAME_MISSION_LIST = .Cells(row, col - 2).Value

        ' 明細開始行
        FindName = "ROW_MISSION_LIST_SHEET_DETAIL_START"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        ROW_MISSION_LIST_SHEET_DETAIL_START = .Cells(row, col - 2).Value

        ' 本体商品型番
        FindName = "COL_MISSION_LIST_SHEET_GOODS_CODE"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_MISSION_LIST_SHEET_GOODS_CODE = .Cells(row, col - 2).Value

        ' 台数履歴
        FindName = "COL_MISSION_LIST_SHEET_BODY_COUNT"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_MISSION_LIST_SHEET_BODY_COUNT = .Cells(row, col - 2).Value

        '受注台数  ←追加列(N)
        FindName = "COL_MISSION_LIST_SHEET_BODY_COUNT_CONTRACT"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_MISSION_LIST_SHEET_BODY_COUNT_CONTRACT = .Cells(row, col - 2).Value

        ' 合計金額
        FindName = "COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_MISSION_LIST_SHEET_CONTRACT_AMOUNT = .Cells(row, col - 2).Value

        ' 計上金額  ←追加列(AF)
        FindName = "COL_MISSION_LIST_SHEET_CONTRACT_ADD_UP"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_MISSION_LIST_SHEET_CONTRACT_ADD_UP = .Cells(row, col - 2).Value

        ' Sheet2 ********************************************************
        ' シート名
        FindName = "SHEET_NAME_DROPDOWN"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        SHEET_NAME_DROPDOWN = .Cells(row, col - 2).Value

        ' 明細開始行
        FindName = "ROW_DROPDOWN_SHEET_DETAIL_START"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        ROW_DROPDOWN_SHEET_DETAIL_START = .Cells(row, col - 2).Value

        ' 商品型番
        FindName = "COL_DROPDOWN_SHEET_GOODS_CODE"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_DROPDOWN_SHEET_GOODS_CODE = .Cells(row, col - 2).Value

        ' 商品金額
        FindName = "COL_DROPDOWN_SHEET_COST"
        row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
        col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
        COL_DROPDOWN_SHEET_COST = .Cells(row, col - 2).Value

        With ThisWorkbook.Worksheets(SHEET_NAME_DROPDOWN)
            row = ROW_DROPDOWN_SHEET_DETAIL_START
            Do
                If .Cells(row, COL_DROPDOWN_SHEET_GOODS_CODE).Value = Empty Then Exit Do

                If Not Not GoodsInfos Then
                    i = UBound(GoodsInfos) + 1
                Else
                    i = 0
                End If
                ReDim Preserve GoodsInfos(i)
                GoodsInfos(i).Code = .Cells(row, COL_DROPDOWN_SHEET_GOODS_CODE).Value
                GoodsInfos(i).Cost = .Cells(row, COL_DROPDOWN_SHEET_COST).Value

                row = row + 1
            Loop
        End With

    End With

    ConstSheetValueToConst = True

ConstSheetValueToConst_End:

    Exit Function

ConstSheetValueToConst_Err:

    MethodName = "ConstSheetValueToConst"
    Call DispErrSetupConst(Err.Number, Err.Description)
    GoTo ConstSheetValueToConst_End

End Function


エラー用コード
<Module2>

Option Explicit

Public FindName As String
Public MethodName As String

Public Const SHEET_NAME_LOG = "ログ"
Public LogRow As Long

' エラー表示
Public Sub DispErrMsg(ErrMsg As String)

    MsgBox ErrMsg
    Call DispLog(ErrMsg)

End Sub

' エラー表示
Public Sub DispErr(ErrNumber As Integer, ErrDescription As String)

    Const ERR_MSG = "【%1】Error[%2」 %3"

    Dim ErrMsg As String

    ErrMsg = Replace(ERR_MSG, "%1", MethodName)
    ErrMsg = Replace(ErrMsg, "%2", ErrNumber)
    ErrMsg = Replace(ErrMsg, "%3", ErrDescription)

    MsgBox ErrMsg:     Call DispLog(ErrMsg)

End Sub

' 定数セットアップ_エラー表示
Public Sub DispErrSetupConst(ErrNumber As Integer, ErrDescription As String)

    Const ERR_MSG_COL_NOT_FOUND = "【%1】定数シートに「%2」の値のセルがありません!!"

    Dim ErrMsg As String

    If ErrNumber = 91 Then    ' Findで見つからない
        ErrMsg = Replace(ERR_MSG_COL_NOT_FOUND, "%1", MethodName)
        ErrMsg = Replace(ErrMsg, "%2", MethodName)
        MsgBox ErrMsg:    Call DispLog(ErrMsg)

    Else
        Call DispErr(ErrNumber, ErrDescription)
    End If

End Sub

' ログ初期化
Public Function InitLog() As Boolean

    Const ERR_MSG = "【%1】Error[%2」 %3"

    Dim ErrMsg As String

    InitLog = False

    On Error GoTo InitLog_Err

    With ThisWorkbook.Worksheets(SHEET_NAME_LOG)
        .Cells.Clear
    End With
    LogRow = 0

    InitLog = True

InitLog_End:

    Exit Function

InitLog_Err:

    MethodName = "InitLog"
    Call DispErr(Err.Number, Err.Description)
    Resume InitLog_End

End Function

' ログ表示
Public Function DispLog(log As String) As Boolean

    DispLog = False

' On Error GoTo DispLog_Err

    With ThisWorkbook.Worksheets(SHEET_NAME_LOG)
        LogRow = LogRow + 1
        .Cells(LogRow, 1).Value = log
    End With

    DispLog = True

DispLog_End:

    Exit Function

'DispLog_Err:
' MethodName = "DispLog"
' Call DispErr(Err.Number, Err.Description)
' Resume DispLog_End

End Function

(ぽんくら) 2019/01/21(月) 14:34


追記

<ThisWorkbook>にも追加列分のコードを追加したところ、AF列(計上金額)が自動計算されるようになったのですが、N列(受注台数)への入力だけでは実行されず、L列(台数履歴)の台数の入力しなおしもしないと自動計算がされませんでした。

他にどこを書き換えれば良いのかわからない状況です、、
(ぽんくら) 2019/01/21(月) 14:43


 載せるだけじゃなくて自分で内容理解して説明してくれません?

 イベントの実行はシートモジュールにある
 >Private Sub Worksheet_Change(ByVal Target As Range) 
 で行っています。
 その範囲の判断は
 >Select Case col
 〜〜〜
 なので、新しい分岐を作って、その中に入れてください。
 回りくどい変数とか作るの面倒なので、
 Case Range("N1").Column

 で十分だと思います。

 以下愚痴。

 >       FindName = "SHEET_NAME_MISSION_LIST"
 >       row = .Cells.Find(What:=FindName, lookat:=xlWhole).row
 >       col = .Cells.Find(What:=FindName, lookat:=xlWhole).Column
 >       SHEET_NAME_MISSION_LIST = .Cells(row, col - 2).Value
 定数シートから、語句を探し出しているだけですよね?
 これ見て、どんな表になっているか回答者に想像(いっそ創造)させるのが趣旨なんですか?

 しかもこんなん1行で書けよ。
 SHEET_NAME_MISSION_LIST = .Cells.Find(What:="SHEET_NAME_MISSION_LIST", lookat:=xlWhole).Offset(,-2).Value

 ThisWOrkbookのエラーを専用なのに、標準モジュールに飛ばしてる意味も分からんし。

 前回申した通りです。
 > 私個人の感想ですが、今あるプログラムも全部破棄して、計算式で作り変えたほうがよっぽどいいと思います。

 以降、プログラムを直す作業はしません。
(稲葉) 2019/01/21(月) 15:13

稲葉さん、ご説明をありがとうございます。
教えていただいたコードを入れたら思い通りの動作になりました!

また、理解できないまま長々とコードを記載してしまい申し訳ありません。。。
今後このような迷惑をかけないようもっと勉強しようと思います。

丸投げの形になってしまったにも関わらず最後までお付き合いいただきありがとうございました!

(ぽんくら) 2019/01/21(月) 15:55


 >今後このような迷惑をかけないようもっと勉強しようと思います。 
 いや、これはコードの進行がよろしくない。
 読みたくなくなる気持ちもすごくよくわかる。

 具体的な表と、目的とした動作さえ教えてもらえれば、もっとシンプルに作り変えます。

 提示いただいたコードは、いわゆるスパゲッティプログラムといっても、たぶんいいと思います。
https://ja.wikipedia.org/wiki/%E3%82%B9%E3%83%91%E3%82%B2%E3%83%86%E3%82%A3%E3%83%97%E3%83%AD%E3%82%B0%E3%83%A9%E3%83%A0

 Wikiさんの特徴を大体包含した素晴らしいスパゲッティです。
 例を挙げます。
 1)goto文の濫用
    On Error GoTo Worksheet_Change_Err
    '(省略)
        '★エラー発生!
        '(a)へ飛ぶ
        'エラーが無かったら、(b)が処理され、終了する
    Worksheet_Change_End:
        '●(b)
        Exit Sub

    Worksheet_Change_Err:
        '●(a)
        MethodName = SHEET_NAME_MISSION_LIST & " Worksheet_Change"
        Call DispErr(Err.Number, Err.Description)
        Resume Worksheet_Change_End
        'エラーを表示させて、(b)へ飛ぶ

    エラー出たらその場で止めときゃええやん。
    やってることはメッセージ表示させてるだけだし、イベントの制御もしてないんだから、いらないでしょ。
    むしろエラーが出る場所を想定できないコードがおかしい。

 2)スコープの拡大 
   標準モジュールにPublicがたくさんありますけど、いらないですよね?
   1)を例に挙げると、MethodNameはModule2にありますが、どこでどう宣言されたのかわからないので、
   探しに行かないといけませんよね?
   で、使われ方はDispErrのメッセージ表示のみ。
   だったら、次のようにDispErrの引数として渡せばええやん。
   Call DispErr(Err.Number, Err.Description, SHEET_NAME_MISSION_LIST & " Worksheet_Change"
)

 他にもツッコミどころあるけど、今後も使い続けるなら、マクロなんか使わず、計算式でやったほうが
 絶対いいですよ。

(稲葉) 2019/01/21(月) 16:42


稲葉さん、今回のコードの詳細な解説までありがとうございます!
スパゲッティプログラムというコードの組み方があるのですね。知りませんでした。

自分でいじったりしながら(コピペだけですが)エラーの部分は全く理解できていませんでした。
不要な部分も多数あったのですね。他の方が書いたものだから今回必要な部分だけ変えれればいいや、というような心境でしたので、自分で調べるのを怠っていました。

それでもかなり簡単なところ(>Select Case col の部分に追加すればよかっただけ)でコードを誤っており、稲葉さんに教えていただくまで気づけませんでした。自分でも反省しています。。すみません。

まだまだ理解できていない部分のほうが多いので、稲葉さんに教えていただいたことを参考にしながら少しずつ自分で見やすいように書き換えていきたいと思います!

それと、一度計算式でもやってみましたがそちらのほうがはるかに簡単でしたし、表が崩れるといった心配にも無縁に感じました。今後も使い続けていくファイルなので計算式での運用についても検討しようと思います。

本当にありがとうございます。おかげで早く問題解決できました!(;V;)

(ぽんくら) 2019/01/21(月) 17:06


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.