金額検討に使えるマクロまとめ

パイプを売るためのマクロをまとめる

下記の続編です。

私が後でコピペするための記事です。
パイプを売る方は少ないと思いますが、ご自身の業務に合わせてアレンジしてお使いください。

（１）材料単価表作成

Sub Macro1()
'材料単価表の作成

    '小見出し
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "材質"
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "サイズ"
    Range("R2").Select
    ActiveCell.FormulaR1C1 = "4m単価"
    Range("S2").Select
    ActiveCell.FormulaR1C1 = "1mm単価"
    
    'VP
    Range("P3").Select
    ActiveCell.FormulaR1C1 = "VP"
    Range("Q3").Select
    ActiveCell.FormulaR1C1 = "100"
    Range("R3").Select
    ActiveCell.FormulaR1C1 = "5290"
   
    Range("P4").Select
    ActiveCell.FormulaR1C1 = "VP"
    Range("Q4").Select
    ActiveCell.FormulaR1C1 = "75"
    Range("R4").Select
    ActiveCell.FormulaR1C1 = "3599"
    
    Range("P5").Select
    ActiveCell.FormulaR1C1 = "VP"
    Range("Q5").Select
    ActiveCell.FormulaR1C1 = "65"
    Range("R5").Select
    ActiveCell.FormulaR1C1 = "2345"
        
    Range("P6").Select
    ActiveCell.FormulaR1C1 = "VP"
    Range("Q6").Select
    ActiveCell.FormulaR1C1 = "50"
    Range("R6").Select
    ActiveCell.FormulaR1C1 = "1840"
    
    'HTVP
    Range("P7").Select
    ActiveCell.FormulaR1C1 = "HTVP"
    Range("Q7").Select
    ActiveCell.FormulaR1C1 = "25"
    Range("R7").Select
    ActiveCell.FormulaR1C1 = "1877"
    
    Range("P8").Select
    ActiveCell.FormulaR1C1 = "HTVP"
    Range("Q8").Select
    ActiveCell.FormulaR1C1 = "40"
    Range("R8").Select
    ActiveCell.FormulaR1C1 = "3384"
    
    'FSVP
    Range("P9").Select
    ActiveCell.FormulaR1C1 = "FSVP"
    Range("Q9").Select
    ActiveCell.FormulaR1C1 = "50"
    Range("R9").Select
    ActiveCell.FormulaR1C1 = "2912"
    
    Range("P10").Select
    ActiveCell.FormulaR1C1 = "FSVP"
    Range("Q10").Select
    ActiveCell.FormulaR1C1 = "65"
    Range("R10").Select
    ActiveCell.FormulaR1C1 = "4020"
    
    Range("P11").Select
    ActiveCell.FormulaR1C1 = "FSVP"
    Range("Q11").Select
    ActiveCell.FormulaR1C1 = "75"
    Range("R11").Select
    ActiveCell.FormulaR1C1 = "4836"
    
    Range("P12").Select
    ActiveCell.FormulaR1C1 = "FSVP"
    Range("Q12").Select
    ActiveCell.FormulaR1C1 = "100"
    Range("R12").Select
    ActiveCell.FormulaR1C1 = "7044"
    
    Range("P13").Select
    ActiveCell.FormulaR1C1 = "ｶﾗｰVP"
    Range("Q13").Select
    ActiveCell.FormulaR1C1 = "75"
    Range("R13").Select
    ActiveCell.FormulaR1C1 = "5675"
        
    Range("P14").Select
    ActiveCell.FormulaR1C1 = "ｶﾗｰVP"
    Range("Q14").Select
    ActiveCell.FormulaR1C1 = "100"
    Range("R14").Select
    ActiveCell.FormulaR1C1 = "8465"

    '1mm単価出し
    Range("S3").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]/4000"
    Range("S3").Select
    Selection.Copy
    Range("S4:S14").Select
    ActiveSheet.Paste
    
    Application.CutCopyMode = False
End Sub

（２）金額計算

Sub Macro2_1()
'１部屋ごとにメートル寸法からミリ寸法へ直す

    '最終列を取得し、最終列まで繰り返す
    '1 → A列が対象
    Dim i
    For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row

        '左横の列のメートル寸法をミリに変換、ヤトイは400に置換
        'Cells(i, 4)の部分を変更して計算結果を表示する列を決定、7→G列
        Cells(i, 8) = "=IFERROR(RC[-2]*1000,400)"
    
        ' Cells(i, 8)が400の場合、セルの色を変える
        If Cells(i, 8) = 400 Then
            ' 灰色
            Cells(i, 8).Interior.Color = RGB(230, 230, 230)
        End If

    Next
    
End Sub

Sub Macro2_2()
'小計・材料費
    
    '小計
    Range("I3").Select
    ActiveCell.FormulaR1C1 = "=INT(RC[1]+RC[2])"
    
    '材料費
    Range("J3").Select
    ActiveCell.FormulaR1C1 = "=INT(RC[-2]*RC[2])"
    
    '複製
    Range("I3:J3").Select
    Selection.Copy
    
        '最終列を取得し、最終列まで繰り返す
        Dim i
        For i = 3 To Cells(Rows.Count, 6).End(xlUp).Row
            Cells(i, 9).Select
            ActiveSheet.Paste
        Next
        
        Application.CutCopyMode = False
        Range("K1").Select
    
End Sub

Sub Macro2_3()
'工費を代入

    '最終列を取得し、最終列まで繰り返す
    Dim i
    For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
    '75A以上は650円
        If Cells(i, 5) >= 75 Then
            Cells(i, 11) = 650
    '65A以下は600円
        Else
            Cells(i, 11) = 600
        End If
    Next

End Sub

Sub Macro2_4()
'材料費単価を代入

    '最終列を取得し、最終列まで繰り返す
    Dim i
    For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
    
            'VP
            If Cells(i, 4) = "VP" And Cells(i, 5) = 100 Then
            Cells(i, 12) = Cells(3, 19)
            ElseIf Cells(i, 4) = "VP" And Cells(i, 5) = 75 Then
            Cells(i, 12) = Cells(4, 19)
            ElseIf Cells(i, 4) = "VP" And Cells(i, 5) = 65 Then
            Cells(i, 12) = Cells(5, 19)
            ElseIf Cells(i, 4) = "VP" And Cells(i, 5) = 50 Then
            Cells(i, 12) = Cells(6, 19)

            'HTVP
            ElseIf Cells(i, 4) = "HTVP" And Cells(i, 5) = 40 Then
            Cells(i, 12) = Cells(7, 19)
            ElseIf Cells(i, 4) = "HTVP" And Cells(i, 5) = 25 Then
            Cells(i, 12) = Cells(8, 19)

            'FSVP
            ElseIf Cells(i, 4) = "FSVP" And Cells(i, 5) = 100 Then
            Cells(i, 12) = Cells(9, 19)
            ElseIf Cells(i, 4) = "FSVP" And Cells(i, 5) = 75 Then
            Cells(i, 12) = Cells(10, 19)
            ElseIf Cells(i, 4) = "FSVP" And Cells(i, 5) = 65 Then
            Cells(i, 12) = Cells(11, 19)
            ElseIf Cells(i, 4) = "FSVP" And Cells(i, 5) = 50 Then
            Cells(i, 12) = Cells(12, 19)

            'ｶﾗｰVP
            ElseIf Cells(i, 4) = "ｶﾗｰVP" And Cells(i, 5) = 100 Then
            Cells(i, 12) = Cells(13, 19)
            ElseIf Cells(i, 4) = "ｶﾗｰVP" And Cells(i, 5) = 75 Then
            Cells(i, 12) = Cells(14, 19)

            End If
            
    Next

End Sub

（３）黒塗りのある列のデータを削除

Sub Macro3()
'黒塗りがある列のデータを削除
'下からループするとなぜかうまくいく
Dim i
For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    
    'セルの背景が黒だった場合、Lまで削除
    If Cells(i, 1).Interior.Color = RGB(0, 0, 0) Then
    
    Cells(i, 1).ClearContents
    Cells(i, 2).ClearContents
    Cells(i, 3).ClearContents
    Cells(i, 4).ClearContents
    Cells(i, 5).ClearContents
    Cells(i, 6).ClearContents
    Cells(i, 7).ClearContents
    Cells(i, 8).ClearContents
    Cells(i, 9).ClearContents
    Cells(i, 10).ClearContents
    Cells(i, 11).ClearContents
    Cells(i, 12).ClearContents
    
    End If
Next
        
End Sub

（４）書式設定

Sub Macro4()
'書式調整
    
    '単価表_小見出し
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "材質"
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "サイズ"
    Range("R2").Select
    ActiveCell.FormulaR1C1 = "4m単価"
    Range("S2").Select
    ActiveCell.FormulaR1C1 = "1mm単価"
    
    '途中計算_小見出し
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "寸法[mm]"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "小計[円]"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "材料費[円]"
    Range("K2").Select
    ActiveCell.FormulaR1C1 = "工費[円]"
    
    '列幅の調整
    Columns("H:S").Select
    Selection.Columns.AutoFit
    
    '灰色
    Columns("L").Select
    With Selection.Font
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0
    End With
    
    Range("K1").Select
        
End Sub

（５）合計欄の作成

Sub Macro5()
'合計欄の作成
    
    '最終行の取得
    Dim r As Long
    r = Cells(Rows.Count, 1).End(xlUp).Row
    
        'パーツ数
        Cells(r + 2, 8) = "パーツ数"
        '3→ｒまでデータ数カウント
        Cells(r + 3, 8) = WorksheetFunction.CountA(Range(Cells(3, 8), Cells(r, 8)))
        
        '小計
        Cells(r + 2, 9) = "小計"
        '3→ｒまで合計
        Cells(r + 3, 9) = WorksheetFunction.Sum(Range(Cells(3, 9), Cells(r, 9)))
        
        '材料費
        Cells(r + 2, 10) = "材料費"
        '3→ｒまで合計
        Cells(r + 3, 10) = WorksheetFunction.Sum(Range(Cells(3, 10), Cells(r, 10)))
        
        '工費
        Cells(r + 2, 11) = "工費"
        '3→ｒまで合計
        Cells(r + 3, 11) = WorksheetFunction.Sum(Range(Cells(3, 11), Cells(r, 11)))
        
        '中央ぞろえ
        Range(Cells(r + 2, 8), Cells(r + 3, 11)).Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        '金額形式
        Range(Cells(r + 3, 9), Cells(r + 3, 11)).Select
        Selection.NumberFormatLocal = "\#,##0_);[赤](\#,##0)"
        
        '黄色
        Range(Cells(r + 2, 8), Cells(r + 3, 8)).Select
        Selection.Interior.Color = 65535
      
End Sub

（６）まとめて実行

Sub hitoheya()
'1部屋まとめて実行
    Call Macro1
    Call Macro2_1
    Call Macro2_2
    Call Macro2_3
    Call Macro2_4
    Call Macro3
    Call Macro4
    Call Macro5
End Sub

参考サイト

（２）
https://www.excel-ubara.com/excelvba1/EXCELVBA320.html
https://www.excel-ubara.com/excelvba1/EXCELVBA322.html
https://daitaideit.com/vba-if-usage/#mokuzi1-3
（３）
https://excel-ubara.com/excelvba1/EXCELVBA339.html
（４）
https://kosapi.com/post-1962/
（５）
https://lilia-study.com/excel/excel-vba/worksheetfunction/counta/
http://keiyu.xyz/2020/11/18/undersum/
https://webs-studio.jp/program/vba/5051/#index_id9
https://www.kotablo.com/entry/excel-vba-numberformatlocal-currency