パイプの発注に使うマクロをまとめる
私が後でコピペするための記事です。
パイプの発注をする方は少ないと思いますが、ご自身の業務に合わせてアレンジしてお使いください。
(1)黒塗り部分の削除
黒塗り部分は弊社には関係ないが、データが入ったまま届く。
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
(2)メートル寸法からミリ寸法へ直す
ミリ寸法が書いていないかつ、ヤトイはカタカナで表示されている。
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, 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
(3)管種・サイズごとの小計を一部屋ごとに出す
ユニーク関数
サムイフス関数
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
(4)全部屋の合計を出す
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
(5)発注数検討
定尺で割る、余りも表示
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 = "4mパイプ[本]"
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
(6)まとめて実行
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
参考サイト
(1)
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/
(2)
https://excel-ubara.com/excelvba1r/EXCELVBA506.html
(3)
https://qiita.com/anya9999/questions/e8dfd599f34069c8bbcd
(4)
https://qiita.com/anya9999/questions/e8dfd599f34069c8bbcd
(5)
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