パイプの発注に使うマクロをまとめる

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

（１）黒塗り部分の削除

黒塗り部分は弊社には関係ないが、データが入ったまま届く。

Sub Macro1()
'黒塗りがある列を削除
'下からループするとなぜかうまくいく
Dim i
For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    
    'セルの背景が黒だった場合、横一列削除
    If Cells(i, 1).Interior.Color = RGB(0, 0, 0) Then
    Rows(i).Delete Shift:=xlShiftUp
    End If
Next
        
End Sub

（２）メートル寸法からミリ寸法へ直す

ミリ寸法が書いていないかつ、ヤトイはカタカナで表示されている。

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

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

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

    Next
    
End Sub

（３）管種・サイズごとの小計を一部屋ごとに出す

ユニーク関数
サムイフス関数

Sub Macro3_1()
'1部屋ごとに管種・サイズをひろう
'20-3=17種類まで対応

Range("M3").Select
ActiveCell.Formula2R1C1 = "=UNIQUE(C[-9]:C[-8])"

Range("I3").Select
    ActiveCell.Formula2R1C1 = _
        "=FILTER(SORTBY(R[0]C[4]:R[18]C[5],R[0]C[4]:R[18]C[4],-1,R[0]C[5]:R[18]C[5],-1),R[0]C[4]:R[18]C[4]<>0)"
        
Range("K3").Select
    
End Sub

Sub Macro3_2()
'管種・サイズごとの小計を1部屋ごとに出す

    Range("K3").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMIFS(R3C7:R1000C7,R3C4:R1000C4,RC9,R3C5:R1000C5,RC10)"
        
    Range("K3").Select
    Selection.Copy
    
        '最終列を取得し、最終列まで繰り返す
        Dim i
        For i = 3 To Cells(Rows.Count, 9).End(xlUp).Row
            Cells(i, 11).Select
            ActiveSheet.Paste
        Next
        Application.CutCopyMode = False
        
End Sub

Sub Macro3_3()
'1部屋ごとの書式設定

    '小見出しの追加
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "材質"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "サイズ"
    Range("K2").Select
    ActiveCell.FormulaR1C1 = "小計"
    
    '格子
    '最終列を取得し、最終列まで繰り返す
    Dim i
    For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
        Range(Cells(i, 9), Cells(i, 11)).Select

        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next
      
    '灰色
    Columns("M:N").Select
    With Selection.Font
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0
    End With
    
    Range("K1").Select
    
End Sub

（４）全部屋の合計を出す

Sub Macro4()
  '全部屋集計
  '集計シートを1枚目に置くことを条件とする

  '既存の集計シートがあれば削除（キャンセルでマクロ終了）
  If Worksheets(1).Name = "集計シート" Then
    If Not Worksheets(1).Delete Then Exit Sub
  End If

  '新しい集計シートの作成準備＜元のプログラムから変更あり＞
  strDataAddress = "" ' VSTACK するセル範囲のアドレス
  For Each ws In Worksheets ' 全てのシートをチェックしてデータ範囲のアドレスを書き出す
    dataRows = ws.Range("I2").CurrentRegion.Rows.Count - 1
        strDataAddress = strDataAddress & ",'" & ws.Name & "'!" & _
                     ws.Range("I3").Resize(dataRows, 3).Address
  Next ws
  strDataAddress = Mid(strDataAddress, 2) ' 先頭の余分な","を削除

  '集計シートの作成
  Set wsAggregate = Worksheets.Add(Worksheets(1)) ' 集計シートを1枚目に置く
  With wsAggregate
    .Name = "集計シート"
    .Range("A2").Formula2 = "=VSTACK(" & strDataAddress & ")" ' 集計シートA2に VSTACK 関数を書く
    Set rangeStack = .Range("A2").CurrentRegion ' VSTACK されたデータのセル範囲
    Set rangeStack_AB = rangeStack.Columns("A:B") ' 上記範囲中で商品名・サイズのセル範囲
    
    ' 集計シートE2に UNIQUE 関数を書く＜元のプログラムから変更あり＞
    .Range("E2").Formula2 = "=SORT(SORT(UNIQUE(" & rangeStack_AB.Address & "),2,-1),1,-1)"
    
    Set rangeUnique = .Range("E2").CurrentRegion ' 商品名・サイズのセル範囲
    'SUMIFS 関数の式を作り、集計シートG2に SUMIFS 関数を書く
    formulaSumifs = Join(Array(rangeStack.Columns(3).Address, _
                               rangeStack.Columns(1).Address, rangeUnique.Columns(1).Address, _
                               rangeStack.Columns(2).Address, rangeUnique.Columns(2).Address), ",")
    .Range("G2").Formula2 = "=SUMIFS(" & formulaSumifs & ")"
    .Range("A1:C1") = Array("材質", "サイズ", "mm")
    .Range("E1:G1") = Array("材質", "サイズ", "mm")
  End With
End Sub

（５）発注数検討

定尺で割る、余りも表示

Sub Macro5_1()
'発注数の検討
    
    '代入
    Range("I2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=RC[-4]"
    Range("J2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=RC[-4]"
    Range("N2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=RC[-7]"
    
    '計算
    Range("L2").Select
    ActiveCell.FormulaR1C1 = "=QUOTIENT(RC[2],4000)"
    Range("M2").Select
    ActiveCell.FormulaR1C1 = "=MOD(RC[1],4000)"
    
    '複製
    Range("I2:N2").Select
    Selection.Copy
    
        '最終列を取得し、最終列まで繰り返す
        Dim i
        For i = 3 To Cells(Rows.Count, 7).End(xlUp).Row
            Cells(i, 9).Select
            ActiveSheet.Paste
        Next
        Application.CutCopyMode = False
    
End Sub

Sub Macro5_2()
'集計シートの書式設定
    
    '小見出しの追加
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "材質"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "サイズ"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "発注数[本]"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "4ｍパイプ[本]"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "半端[mm]"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "1フロア合計[mm]"
    Range("N2").Select
    
    '列幅の調整
    Columns("I:N").Select
    Selection.Columns.AutoFit
    
    '格子
        '最終列を取得し、最終列まで繰り返す
        Dim i
        For i = 1 To Cells(Rows.Count, 9).End(xlUp).Row
            Range(Cells(i, 9), Cells(i, 11)).Select
    
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Next
    
    '灰色
    Columns("A:H").Select
    With Selection.Font
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0
    End With
    
    Range("K2").Select
End Sub

（６）まとめて実行

Sub hitoheya()
'1部屋まとめて実行
    Call Macro1
    Call Macro2
    Call Macro3_1
    Call Macro3_2
    Call Macro3_3
End Sub

Sub zenheya()
'全部屋まとめて実行
    Call Macro4
    Call Macro5_1
    Call Macro5_2
End Sub

参考サイト

（１）
https://www.rapidtables.org/ja/web/color/RGB_Color.html
https://kirinote.com/excelvba-color-valueclear/
https://excel-toshokan.com/vba-delete-row/
https://daitaideit.com/vba-delete-specific-row/
（２）
https://excel-ubara.com/excelvba1r/EXCELVBA506.html
（３）
https://qiita.com/anya9999/questions/e8dfd599f34069c8bbcd
（４）
https://qiita.com/anya9999/questions/e8dfd599f34069c8bbcd
（５）
https://support.microsoft.com/ja-jp/office/quotient-%E9%96%A2%E6%95%B0-9f7bf099-2a18-4282-8fa4-65290cc99dee#:~:text=%E3%81%93%E3%81%93%E3%81%A7%E3%81%AF%E3%80%81Micro
https://support.microsoft.com/ja-jp/office/mod-%E9%96%A2%E6%95%B0-9b6cd169-b6ee-406a-a97b-edf2a9dc24f3#:~:text=MOD%20%E9%96%A2%E6%95%B0.%20%E3%81%9D%E3%81%AE