エクセルVBAマクロ実例【生産現場実使用-定型作業自動化】

■Module1-サンプルA(共通部分マクロ)

Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Option Private Module

Sub フィルタ削除01()
'ω'フィルタ非該当不要行削除作業、ﾌｨﾙﾀ該当分のﾃﾞｰﾀを残す

Dim sname As String
sname = ActiveSheet.Name

Worksheets(sname).Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "削除01"
Worksheets("削除01").Range("A1").PasteSpecial Paste:=xlPasteAll

Worksheets(sname).AutoFilterMode = False
Sheets(sname).Cells.Clear

Worksheets("削除01").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets(sname).Range("A1").PasteSpecial Paste:=xlPasteAll
Sheets("削除01").Cells.Clear

'ω'不要作業シート削除
Sheets("削除01").Delete

End Sub

Sub 連番1以外削除01()
'ω'8列目に対し26列目に連番追加

Dim MR As Long
Dim i As Long
Dim j As Long

MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
j = 1

ZZ = Range(Cells(1, 26), Cells(MR, 26))
HH = Range(Cells(1, 8), Cells(MR + 1, 8))

For i = 2 To MR
ZZ(i, 1) = j
j = j + 1
If HH(i, 1) <> HH(i + 1, 1) Then
j = 1
End If
Next i
Range(Cells(1, 26), Cells(MR, 26)) = ZZ

'ω'連番1以外削除
Cells(1, 26) = "削除"
Cells(1, 26).AutoFilter Field:=1, Criteria1:=1
End Sub

Sub サンプルA01_1() 'ω'K
'ω'部品割当リスト、部品割当リスト_最新.xlsxで保存、検討データ・祝日シート追加

'ω'アクティブシート以外のシートを削除
Worksheets("サンプルAデータリスト").Activate
Dim mySht As Worksheet
For Each mySht In Worksheets
If mySht.Name <> ActiveSheet.Name Then mySht.Delete
Next

End Sub

Sub サンプルA01_2()
'ω'該当倉庫以外データ削除
ActiveSheet.Cells(1, 1).AutoFilter Field:=32, Criteria1:=Array("99924", "99925", "99927", "99903", "99904", "99905"), Operator:=xlFilterValues
フィルタ削除01

'ω'B予定日書き換え
Dim MR As Long
Dim MC As Long
MR = Cells(Rows.Count, 20).End(xlUp).Row 'ω'最終行,T:T
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列

Range(Cells(1, 18), Cells(MR, 18)).Replace What:="現地生産", replacement:="AAA"

'ω'リスト並べ替え(1:現地生産,2:倉庫コード)
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 18), Order1:=xlAscending, _
Header:=xlYes

JJ = Range(Cells(1, 10), Cells(MR, 10)) 'ω'A予定日→B予定日を逐次代入
FF = Range(Cells(1, 18), Cells(MR, 18)) 'ω'現地生産,AAA
ZZ = Range(Cells(1, 52), Cells(MR, 52)) 'ω'B予定日

For i = 2 To MR
If FF(i, 1) <> "AAA" Then
Range(Cells(1, 10), Cells(MR, 10)) = JJ
i = MR
Else
JJ(i, 1) = ZZ(i, 1)
End If
Next i

End Sub

Sub サンプルA01_3() 'ω'K
'ω'アクティブシート倍率100%,メモリ不足回避
ActiveWindow.Zoom = 100

'ω'先行処理データを元データに加算
Dim MR As Long
MR = Cells(Rows.Count, 20).End(xlUp).Row 'ω'最終行,T:T

'ω'36=AJ,37=AK,Variant
Dim i As Long, K As Long, L As Long, M As Long
c = Range(Cells(1, 36), Cells(MR, 37))
d = Range(Cells(1, 36), Cells(MR, 36))
For i = 2 To MR
K = c(i, 1)
L = c(i, 2)
d(i, 1) = K + L
Next i
Range(Cells(1, 36), Cells(MR, 36)) = d

'ω'不要列削除
Range("BI:BP").Delete
Range("BD:BF").Delete
Range("AR:BA").Delete
Range("AK:AP").Delete
Range("AG:AI").Delete
Range("AC:AE").Delete
Range("Z:Z").Delete
Range("U:X").Delete
Range("K:S").Delete
Range("F:I").Delete
Range("C:C").Delete

'ω'列並替
Range("F:F").Cut 'ω'Sオーダ
Range("B:B").Insert

'ω'看板列空白MRP置換
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
Range(Cells(1, 16), Cells(MR, 16)).Replace What:="", replacement:="MRP" 'ω'16=P

ActiveWorkbook.SaveAs "D:\部品割当リスト_最新.xlsx", FileFormat:=xlOpenXMLWorkbook

Workbooks.Open ("D:\a.csv")
Workbooks("a.csv").Worksheets("a").Copy After:=Workbooks("部品割当リスト_最新.xlsx").Sheets(Workbooks("部品割当リスト_最新.xlsx").Sheets.Count)
Workbooks("a.csv").Close
End Sub

Sub サンプルA01_4()
Workbooks.Open ("D:\STA化検討リスト.xls")
Workbooks("STA化検討リスト.xls").Worksheets("祝日").Copy After:=Workbooks("部品割当リスト_最新.xlsx").Sheets(Workbooks("部品割当リスト_最新.xlsx").Sheets.Count)
Workbooks("STA化検討リスト.xls").Close

End Sub

Sub サンプルA02()
'ω'STA化検討データ事前保存
'ω'オーダSYK計算
Workbooks.Open ("D:\QSAMP_STA化検討データ.xls")
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook

Cells(1, 17) = "オーダSYK"

Dim MR As Long
MR = Cells(Rows.Count, 1).End(xlUp).Row 'ω'最終行,A:A
'ω'11=K,13=M,17=Q,Variant
Dim i As Long, K As Long, L As Long, M As Long
c = Range(Cells(1, 11), Cells(MR, 13))
d = Range(Cells(1, 17), Cells(MR, 17))
For i = 2 To MR
K = c(i, 1)
L = c(i, 2)
M = c(i, 3)
d(i, 1) = K + L - M
Next i
Range(Cells(1, 17), Cells(MR, 17)) = d

'ω'STA化検討データ→部品割当リスト、シートコピー
ActiveSheet.Copy After:=Workbooks("部品割当リスト_最新.xlsx").Sheets(Workbooks("部品割当リスト_最新.xlsx").Sheets.Count)
ActiveSheet.Name = "検デ"
wb1.Close

End Sub

Sub サンプルA03() 'ω'K

'ω'部品割当リストから不要行(Kオーダ割当重複)削除

Worksheets("サンプルAデータリスト").Activate

Dim MR As Long
Dim MC As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列
'ω'key1=Sｵｰﾀﾞ,key2=位置
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 2), Order1:=xlAscending, _
Key2:=Cells(2, 7), Order2:=xlAscending, _
Header:=xlYes

'ω'2=Sｵｰﾀﾞ,7=位置,26=Z,C,DVariant
Dim i As Long, K As String, L As String
c = Range(Cells(1, 2), Cells(MR, 7))
d = Range(Cells(1, 26), Cells(MR, 26))
For i = 2 To MR
K = c(i, 1)
L = c(i, 6)
d(i, 1) = K + L
Next i
Range(Cells(1, 26), Cells(MR, 26)) = d

Dim j As Long
With Cells(2, 26)
For j = .CurrentRegion.Rows.Count To 1 Step -1
If .Offset(j, 0) = .Offset(j - 1, 0) Then .Offset(j, 0).EntireRow.Delete
Next j
End With

Range("Z:Z").Delete

End Sub

Sub サンプルA04_1() 'ω'K
'ω'D部門以外必要割当データ追加
'ω'サンプルAデータPN検索行A列追加
Dim ws1 As Worksheet
Set ws1 = Worksheets("サンプルAデータリスト")

ws1.Activate
Range("H:H").Copy 'ω'PN
Range("A:A").Insert

Worksheets("a").Activate
Range("E:E").Cut 'ω'Sオーダ
Range("B:B").Insert
Range("E:E").Cut 'ω'終了予定日
Range("C:C").Insert
Range("C:E").Insert
Range("G:I").Insert
Range("1:1").Insert
Range("A1:P1") = "-"

Dim MR As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B

Range(Cells(2, 3), Cells(MR, 5)) = "-"
Range(Cells(2, 7), Cells(MR, 7)) = "-"
'ω'PN
Range(Cells(2, 8), Cells(MR, 8)).Formula = "=MID(A2,10,15)"
Range(Cells(2, 8), Cells(MR, 8)).Value = Range(Cells(2, 8), Cells(MR, 8)).Value

For i = 2 To MR
Cells(i, 9) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 10, False) 'ω'品名
Cells(i, 12) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 13, False) 'ω'サプライヤ
Cells(i, 13) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 14, False) 'ω'手持在庫
Cells(i, 14) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 15, False) 'ω'使用予定在庫
Cells(i, 15) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 16, False) 'ω'供給時間
Next i

'ω'「計画担当者」書き換え,看板
Range(Cells(2, 16), Cells(MR, 16)) = "看板"

End Sub

Sub サンプルA04_2()

'ω'サンプルAにデータがない場合検デより追加
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("検デ")
Set ws2 = Worksheets("a")

'ω'Worksheets("a").Activate
Cells(1, 1).AutoFilter Field:=9, Criteria1:=Array("#N/A"), Operator:=xlFilterValues
If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
'ω'なにもしない,MsgBox "データがありません"
Else
'ω'検デより値取得,99924,99925,99927以外データなし,MsgBox "データがあります"

Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "削除02"
'ω'Worksheets("削除02").Activate
Cells(1, 1).PasteSpecial Paste:=xlPasteAll

Dim MR As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
For i = 2 To MR
Cells(i, 9) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 3, False) 'ω'品名
Cells(i, 12) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 8, False) 'ω'サプライヤ
Cells(i, 13) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 11, False) 'ω'手持在庫
Cells(i, 14) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 13, False) 'ω'使用予定在庫
Cells(i, 15) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 5, False) 'ω'供給時間
Next i

ws2.Activate
ws2.AutoFilterMode = False
Cells(1, 1).AutoFilter Field:=9, Criteria1:="<>#N/A"
フィルタ削除01

ws2.Activate
Dim MS As Long
MS = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B

Worksheets("削除02").Activate
Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy

ws2.Activate
Cells(MS + 1, 1).PasteSpecial Paste:=xlPasteAll
Rows(MS + 1).Delete

'ω'不要作業シート削除
Sheets("削除02").Delete

End If

End Sub

Sub サンプルA04_3()

'ω'99924,99925,99927以外の倉庫を削除
Worksheets("a").Activate
ActiveSheet.Cells(1, 1).AutoFilter Field:=10, Criteria1:=Array("99924", "99925", "99927"), Operator:=xlFilterValues
フィルタ削除01
End Sub

Sub サンプルA04_4() 'ω'K
'ω'データコピー追加
Worksheets("a").Activate
Dim MR As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B

Range(Cells(2, 2), Cells(MR, 16)).Copy
Worksheets("サンプルAデータリスト").Activate
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
Cells(MR + 1, 3).PasteSpecial Paste:=xlPasteAll

'ω'サンプルAデータPN検索行A列削除
Columns(1).Delete

End Sub

Sub サンプルA05() 'ω'K
'ω'S製品、工程3日追加L製品に合わせる

'ω'    Worksheets("サンプルAデータリスト").Activate
Dim MR As Long
Dim MC As Long
Dim X As Date
'ω'Dim D As Variant

MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B

d = Range(Cells(1, 6), Cells(MR, 6))
Range(Cells(1, 17), Cells(MR, 17)) = d

'ω'機名S製品フィルタ
Call S製品F("C1", 3)
Cells(1, 1).AutoFilter Field:=10, Criteria1:=Array("99925", "99927", "99928", "99929"), Operator:=xlFilterValues
Cells(1, 1).AutoFilter Field:=16, Criteria1:=Array("看板"), Operator:=xlFilterValues

If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
Worksheets("サンプルAデータリスト").AutoFilterMode = False
Else

'ω'F列可視セル終了予定日にQ2,S製品工程3日追加終了予定日を相対位置で入力
For Each c In Worksheets("サンプルAデータリスト").Range(Cells(2, 6), Cells(MR, 6)).SpecialCells(xlCellTypeVisible)
X = Cells(c.Row, 17) + 3
Cells(c.Row, 6) = X
Next c

Range(Cells(2, 6), Cells(MR, 6)).SpecialCells(xlVisible).Interior.ColorIndex = 22
Worksheets("サンプルAデータリスト").AutoFilterMode = False

End If

'ω'不要列削除
Columns(17).Delete

'ω'部品割当リスト並べ替え(1:pn,2:終了予定日1)
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列

Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 8), Order1:=xlAscending, _
Key2:=Cells(2, 6), Order2:=xlAscending, _
Header:=xlYes

End Sub

Sub サンプルA06() 'ω'K
'ω'部品割当リスト、使用数(見積数)加算、列追加、MC追加列、K出庫数、HPN
'ω'Worksheets("サンプルAデータリスト").Activate

Dim i As Long
Dim j As Long
Dim MR As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
j = 0

QQ = Range(Cells(1, 17), Cells(MR, 17))
KK = Range(Cells(1, 11), Cells(MR, 11))
HH = Range(Cells(1, 8), Cells(MR + 1, 8))

'ω'11=K,8=H
For i = 2 To MR
QQ(i, 1) = KK(i, 1) + j
j = QQ(i, 1)
If HH(i, 1) <> HH(i + 1, 1) Then
j = 0
End If
Next i
Range(Cells(1, 17), Cells(MR, 17)) = QQ


'ω''ω'上書保存メモリ解放
'ω'ActiveWorkbook.SaveAs "D:\部品割当リスト_最新.xlsx", FileFormat:=xlOpenXMLWorkbook

End Sub
Sub サンプルA07()
'ω'部品割当リスト、在庫-使用数=残り、列追加
'ω'部品割当リスト、注残、列追加
'ω'部品割当リスト、残り+注残=注残分含残り、列追加
'ω'部品割当リスト、オーダSYK、列追加
'ω'Worksheets("サンプルAデータリスト").Activate

Dim i As Long
Dim MR As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("検デ")
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
For i = 2 To MR
Cells(i, 19) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 12, False) 'ω'オーダ済
Cells(i, 21) = Application.VLookup(Cells(i, 8), ws1.Range("A:Q"), 17, False) 'ω'オーダSYK
Next i

Dim M As Long, Q As Long, R As Long, S As Long
MM = Range(Cells(1, 13), Cells(MR, 13))
QQ = Range(Cells(1, 17), Cells(MR, 17))
RR = Range(Cells(1, 18), Cells(MR, 18))
SS = Range(Cells(1, 19), Cells(MR, 19))
TT = Range(Cells(1, 20), Cells(MR, 20))
On Error Resume Next 'ω'#N/A無視
For i = 2 To MR
M = MM(i, 1)
Q = QQ(i, 1)
RR(i, 1) = M - Q
R = RR(i, 1)
S = SS(i, 1)
TT(i, 1) = R + S
Next i
On Error GoTo 0 'ω'#N/A無視解除
Range(Cells(1, 18), Cells(MR, 18)) = RR
Range(Cells(1, 20), Cells(MR, 20)) = TT

'ω'部品割当リスト、MC最終列取得の為最後に項目追記
Cells(1, 17) = "使用数"
Cells(1, 18) = "残り"
Cells(1, 19) = "注残"
Cells(1, 20) = "注残含残り"
Cells(1, 21) = "オーダSYK"

End Sub

Sub サンプルAS1(ByVal str As String, ByVal i As Long, ByVal j As Long) 'ω'ｼｰﾄ名,ﾌｨﾙﾀ列,ﾌｨﾙﾀ使用1or0

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = str
Worksheets("サンプルAデータリスト").Activate
Cells(1, 1).AutoFilter Field:=16, Criteria1:=Array("発注停止", "マニュアル", "看板"), Operator:=xlFilterValues
If j = 1 Then
Cells(1, 1).AutoFilter Field:=i, Criteria1:="<=0" 'ω'注残含む残り
End If
Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets(str).Activate
Cells(1, 1).PasteSpecial Paste:=xlPasteAll
Worksheets("サンプルAデータリスト").AutoFilterMode = False

End Sub

Sub サンプルAS2(ByVal i As Long, ByVal j As Long) 'ω'ｼｰﾄ名,ﾌｨﾙﾀ列,ﾌｨﾙﾀ使用1or0
Dim MR As Long
Dim MC As Long

'ω'リスト並べ替え
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, i), Order1:=xlAscending, _
Key2:=Cells(2, j), Order2:=xlAscending, _
Header:=xlYes

End Sub

Sub サンプルA09_1() 'ω'K
'ω'仮01、シートコピー(欠品防止購買用,SJ倉庫10日,SK倉庫12日先,部品使用3日前,フィルタで使用)
Dim MR As Long
Dim MC As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("祝日")

Call サンプルAS1("仮01", 20, 1)

MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 15), Order1:=xlDescending, _
Header:=xlYes

'ω'U列可視セルに相対位置で入力,U列：LT考慮終了予定日

VV = Range(Cells(1, 6), Cells(MR, 6)) 'ω'A予定日→LT考慮日を逐次代入
OO = Range(Cells(1, 15), Cells(MR, 15))

For i = 2 To MR
If OO(i, 1) = 5 Then
Range(Cells(1, 22), Cells(MR, 22)) = VV
i = MR
Else
VV(i, 1) = WorksheetFunction.Workday(Cells(i, 6), -1 * Cells(i, 15).Value + 5, ws1.Range("A1:A10"))
End If
Next i
Cells(1, 22) = "LT考慮終了予定日"

Range(Cells(2, 22), Cells(MR, 22)).NumberFormatLocal = "yyyy/m/d"

Call サンプルAS2(8, 20) 'ω'リスト並べ替え(1:PN,2:注残含む残り)

End Sub

Sub サンプルA09_2() 'ω'K
'ω'仮02、シートコピー(1週間先使用分,未納確認用)
Call サンプルAS1("仮02", 18, 1)

連番1以外削除01
フィルタ削除01

Worksheets("仮02").Activate
Call サンプルAS2(6, 8) 'ω'リスト並べ替え(1:終了予定日1,2:pn)

End Sub

Sub サンプルA09_3() 'ω'K
'ω'仮03、シートコピー(注残含残り欠品日確認用)

Worksheets("仮01").Copy After:=Workbooks("部品割当リスト_最新.xlsx").Sheets(Workbooks("部品割当リスト_最新.xlsx").Sheets.Count)
ActiveSheet.Name = "仮03"

Worksheets("仮03").AutoFilterMode = False
Call サンプルAS2(8, 6) 'ω'リスト並べ替え(1:PN,2:A予定日)

連番1以外削除01
フィルタ削除01

Call サンプルAS2(6, 8) 'ω'リスト並べ替え(1:終了予定日1,2:pn)

End Sub

Sub サンプルA10() 'ω'K
'ω'部品割当リスト、列幅調整、ウィンドウ固定、オートフィルタ追加

Sheets("サンプルAデータリスト").Select
Columns("A:B").AutoFit 'ω'S番,Sオーダ
Columns("E:E").ColumnWidth = 3 'ω'台数
Range("F:F").NumberFormatLocal = "yyyy/m/d" 'ω'終了予定
Columns("F:F").ColumnWidth = 12 'ω'終了予定
Columns("G:H").AutoFit 'ω'位置,PN
Columns("J:K").ColumnWidth = 6 'ω'倉庫,出庫
Columns("M:O").ColumnWidth = 6 'ω'在庫,割当,時間
Columns("Q:U").ColumnWidth = 6 'ω'使用数~

Rows("2:2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter

For i = 4 To 6 'ω'仮01,仮02,仮03
With Worksheets(i)
.Select
Columns("A:B").AutoFit 'ω'S番,Sオーダ
Columns("E:E").ColumnWidth = 3 'ω'台数
Range("F:F").NumberFormatLocal = "yyyy/m/d" 'ω'終了予定
Columns("F:F").ColumnWidth = 12 'ω'終了予定
Columns("G:H").AutoFit 'ω'位置,PN
Columns("J:K").ColumnWidth = 6 'ω'倉庫,出庫
Columns("M:O").ColumnWidth = 6 'ω'在庫,引当,時間
Columns("Q:U").ColumnWidth = 6 'ω'使用数~

Rows("2:2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
End With
Next

End Sub

Sub サンプルA11() 'ω'K
'ω'部品割当リスト、Dドライブ保存

'ω'アクティブシート倍率85%
Worksheets("サンプルAデータリスト").Activate
ActiveWindow.Zoom = 85

ActiveWorkbook.SaveAs "D:\部品割当リスト_最新bu.xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.SaveAs "D:\部品割当リスト_最新.xlsx", FileFormat:=xlOpenXMLWorkbook

End Sub

Sub S製品F(ByVal str As String, ByVal fld As Long)

'ω'str:フィルタをかけるセル(例："A1"),fld:フィルタをかける列番号(例：9)
Range(str).AutoFilter Field:=fld, Criteria1:=Array( _
"TUO100G", "TUO100GZ", "TUO15-D", "TUO200G", "TUO200G-H", "TUO25-D", "TUO25-D-CE", "TUO70MZ-D", "TUO70MZ-D-CE", "TUO70G", "TUO70G-D", "TUO70G-D-CE", "TUO70GL-ZK", "TUO70GZ", "TUO70GZ-D", "TUO80G-HDF", "TUO80GZ-HDF", "CQC100", "CQC100-CZ", "CQC100GZ", "CQC101G", "CQC200G", "CQC200GZ", "CQC200GZ-CE", "CQC201G", "CQC20Z", "CQC20Z-CE", "CQC20Z-HTESD", "CQC30", "CQC30Z", "CQC80G", "CQC80GZ", "CQC80GZ-CE", "ZT-F06", "ZT-F10", "ZT-F10-2S", "ZT-F10-2S-FRD", "ZT-F10-2U", "ZT-F10-2U-FRD", "ZT-F10-3S", "ZT-F10-3S-FRD", "ZT-F10-3U", "ZT-F10-3U-FRD", "ZT-S100", "ZT-S100Z", "ZT-S100Z-CR", "ZT-S100Z", "ZT-S20", "ZT-S200", "ZT-S200Z", "ZT-S200Z", "ZT-S20Z", "ZT-S20Z-ERDC", "ZT-S20ZE", "ZT-S20Z", "ZT-S20Z-ERD", "ZT-S21", "ZT-S30", "ZT-S30L", "ZT-S50", "ZT-S50Z", "ZT-S50Z", "ZT-SF20", "ZT-M20Z", "ZT-M20Z-E", "ZT-M20Z-E-HZ", "ZT-M20Z-HZ", "ZT-M20Z-M", "ZT-M20Z-M-HZ", "ZT-M20Z-ME", "ZT-M20Z-ME-HZ", "ZT-M20ZS", "ZT-M20ZS-E", "ZT-M20ZS-E-HZ", "ZT-M20ZS-HZ", "ZT-M20ZS-M", "ZT-M20ZS-M-HZ", "ZT-M20ZS-ME", "ZT-M20ZS-ME-HZ", _
"CQC40GZ-CE", "CQC70GZ", "CQC70GZ-CE", "CQC72GZ", "TUO25D", "TUO70-MZ", "TUO70GD", "TUO100F", "CQC100G", "CQC200GZ-IU", "CQC20Z", "ZT-S", "ZTS100Z", "ZTS200Z", "ZT-S20F", "ZTS20Z ", "ZT-S50Z-CE", "ZT-S804G", "ZT-S804", "CQC100", "CQC100Z", "CQC100ZF", "CQC100Z-CE", "ZDV", "ZDV250", "ZDV250-GB", "ZDV250-DSZ", "ZDV500", "ZDV500-GB", "ZDV500-DSZ", "ZDV50", "ZT-F03", "TUO70GL", "ZTーS200Z", "ZTーS100Z", "ZTーS100Z", "ZTーS20Z", "GDD80GZ", "ZT-S20Z ", "ZTF10", "ZT-S200GZ", "CQC80Z", "CQC20Z-HT", "ZT-F03-1", "ZT-F03-3", "ZT-F06-1", "ZT-S20Z ", "ZTーS020Z", "CQC20ZHT-ESD", "ZTS-200Z", "ZT-F03-2", "ZT-M100Z", "CQC20", "ZT-M505ZF-BE-HZ", "TUO100G-EM", "FF200G-H-LT ", "ZT-F06-2", "CQC20Z-HTSED", "CQC100-CE", "ZT-20Z", "ZT-M20-E", "ZDV500GB", "CQC100GZ-CE", "ZT-F10-3", "ＥＶ－ＳＡ２０", "CQC100GZ-HT", "ZT-S50orZT-S20", "ZT-S100Z-M", "ZT-S20Z(400V)", "ZDV250GB", "CQC20Z HTESD", "ZDV50-F", "ZDV50-MZ", "ZDV50-M", "ZT-L100Z", "ZT-L100ZS-H", "ZT-F10-3U-Z"), _
Operator:=xlFilterValues

'ω'S製品リスト

End Sub

Sub 発送SF(ByVal str As String, ByVal fld As Long)

'ω'str:フィルタをかけるセル(例："A1"),fld:フィルタをかける列番号(例：9)
Range(str).AutoFilter Field:=fld, Criteria1:=Array( _
"557274999", "522757999", "592724999", "595525999", "595625999", "524498999", "529654999", "556755999", "592262999", "596952999", _
"229289999", "587462999", "599494999", "529525999", "499522999", "555565999", "598822999", "569672999", "599274999", _
"522992999", "522485999", "522562999", "595685999", "594994999", "592579999", "592262999", "599956999", "556959999", "595996999", _
"526288999", "522785999", "596875999", "429555999"), _
Operator:=xlFilterValues

End Sub

■Module2-サンプルK(実行部分マクロ)

Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1

Private Sub サンプルK01()
Workbooks.Open ("D:\サンプルAデータ_" & Format(Date, "yymmdd") & ".xlsx")
End Sub

Private Sub サンプルK02()
サンプルA01_1
End Sub

Private Sub サンプルK04_1()

Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
Workbooks("■■■看板発注マクロ.xlsm").Worksheets("祝日").Copy After:=wb1.Sheets(wb1.Sheets.Count)

'ω'看板以外データ削除
Worksheets("サンプルAデータリスト").Activate
ActiveSheet.Cells(1, 1).AutoFilter Field:=60, Criteria1:=Array("看板"), Operator:=xlFilterValues
フィルタ削除01

'ω'99928,99929,5日以前削除
Dim ws1 As Worksheet
Set ws1 = Worksheets("祝日")
Dim buf As Date
Dim MR As Long
MR = 0

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "作業01"
buf = WorksheetFunction.WorkDay(Date, -5, ws1.Range("A1:A10"))

Worksheets("サンプルAデータリスト").Activate
Cells(1, 1).AutoFilter Field:=32, Criteria1:=Array("99924", "99925", "99927"), Operator:=xlFilterValues

Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets("作業01").Cells(MR + 1, 1).PasteSpecial Paste:=xlPasteAll

Worksheets("作業01").Activate
MR = Cells(Rows.Count, 20).End(xlUp).Row 'ω'最終行,T:T


Worksheets("サンプルAデータリスト").Activate
Cells(1, 1).AutoFilter Field:=32, Criteria1:=Array("99928", "99929"), Operator:=xlFilterValues
Cells(1, 1).AutoFilter Field:=52, Criteria1:=">=" & buf

Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets("作業01").Cells(MR + 1, 1).PasteSpecial Paste:=xlPasteAll

Worksheets("作業01").Activate
Rows(MR + 1).Delete

Worksheets("サンプルAデータリスト").Delete
Worksheets("作業01").Name = "サンプルAデータリスト"

End Sub

Private Sub サンプルK04_2()

'ω'99928,99929,A予定⇒部品使用予定日書き換え
'ω'99924,99925,99927,kd,A予定⇒部品使用予定日書き換え
Dim MR As Long
Dim MC As Long
MR = Cells(Rows.Count, 20).End(xlUp).Row 'ω'最終行,T:T
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列

'ω'リスト並べ替え(1:倉庫コード)
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 32), Order1:=xlDescending, _
Header:=xlYes

JJ = Range(Cells(1, 10), Cells(MR, 10)) 'ω'A予定日→部品使用予定日を逐次代入
FF = Range(Cells(1, 32), Cells(MR, 32)) 'ω'倉庫ｺｰﾄﾞ
ZZ = Range(Cells(1, 52), Cells(MR, 52)) 'ω'部品使用予定日

For i = 2 To MR
If FF(i, 1) <= 99927 Then
Range(Cells(1, 10), Cells(MR, 10)) = JJ
i = MR
Else
JJ(i, 1) = ZZ(i, 1)
End If
Next i

Range(Cells(1, 18), Cells(MR, 18)).Replace What:="現地生産", replacement:="AAA"
'ω'リスト並べ替え(1:kd,2:倉庫コード)
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 18), Order1:=xlAscending, _
Key2:=Cells(2, 32), Order2:=xlAscending, _
Header:=xlYes

JJ = Range(Cells(1, 10), Cells(MR, 10)) 'ω'A予定予定日→部品使用予定日を逐次代入
FF = Range(Cells(1, 32), Cells(MR, 32)) 'ω'倉庫ｺｰﾄﾞ
ZZ = Range(Cells(1, 52), Cells(MR, 52)) 'ω'部品使用予定日

For i = 2 To MR
If FF(i, 1) >= 99928 Then
Range(Cells(1, 10), Cells(MR, 10)) = JJ
i = MR
Else
JJ(i, 1) = ZZ(i, 1)
End If
Next i

End Sub

Private Sub サンプルK05()
サンプルA01_3
End Sub

Private Sub サンプルK07()
'ω'注残計算
Dim MP As String
MP = "D:\"
Workbooks.Open Filename:="D:\" & Dir(MP & "czan_H*.csv")
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook

'ω'注番[*計画*]データ削除
ActiveSheet.Cells(1, 1).AutoFilter Field:=2, Criteria1:="<>*計画*", Operator:=xlFilterValues
フィルタ削除01
'ω'該当倉庫以外データ削除
ActiveSheet.Cells(1, 1).AutoFilter Field:=18, Criteria1:=Array("99924", "99925", "99927", "99928", "99929", "99903", "99904", "99905"), Operator:=xlFilterValues
フィルタ削除01

'ω'不要列削除
Range("H:U").Delete
Range("A:D").Delete

'ω'数の合計,A列についてC列の数を合計する
MR = Cells(Rows.Count, 1).End(xlUp).Row 'ω'最終行,B:B
For i = 2 To MR
Cells(i, 4) = WorksheetFunction.SumIf(Range(Cells(2, 1), Cells(MR, 1)), Cells(i, 1), Range(Cells(2, 3), Cells(i, 3)))
Next i

Cells(1, 4) = "注残"

'ω'連番追加1以外削除
'ω'Dim MR As Long
Dim MC As Long
'ω'Dim i As Long
Dim j As Long
MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
MC = Cells(1, Columns.Count).End(xlToLeft).Column 'ω'1:1,最終列
Range(Cells(1, 1), Cells(MR, MC)).Sort _
Key1:=Cells(2, 1), Order1:=xlAscending, _
Header:=xlYes
j = 1
ZZ = Range(Cells(1, 26), Cells(MR, 26))
AA = Range(Cells(1, 1), Cells(MR + 1, 1))
For i = 2 To MR
ZZ(i, 1) = j
j = j + 1
If AA(i, 1) <> AA(i + 1, 1) Then
j = 1
End If
Next i
Range(Cells(1, 26), Cells(MR, 26)) = ZZ
Cells(1, 26) = "削除"
Cells(1, 26).AutoFilter Field:=1, Criteria1:=1
フィルタ削除01

'ω'STA化検討データ→部品割当リスト、シートコピー
ActiveSheet.Copy After:=Workbooks("部品割当リスト_最新.xlsx").Sheets(Workbooks("部品割当リスト_最新.xlsx").Sheets.Count)
ActiveSheet.Name = "検デ"
wb1.Close

End Sub

Private Sub サンプルK08()
サンプルA03
End Sub

Private Sub サンプルK09()
サンプルA04_1
End Sub

Private Sub サンプルK10()
'ω'サンプルAにデータがない場合ドライ以外必要割当削除
'ω'品名[#N/A]データ削除
Cells(1, 1).AutoFilter Field:=9, Criteria1:="<>#N/A", Operator:=xlFilterValues
フィルタ削除01
End Sub

Private Sub サンプルK11()

'ω'99924,99925,99927,99928,99929以外の倉庫を削除
Worksheets("a").Activate
ActiveSheet.Cells(1, 1).AutoFilter Field:=10, Criteria1:=Array("99924", "99925", "99927", "99928", "99929"), Operator:=xlFilterValues
フィルタ削除01
End Sub

Private Sub サンプルK12()
サンプルA04_4
End Sub

Private Sub サンプルK13()
サンプルA05
End Sub

Private Sub サンプルK14()
サンプルA06
End Sub
Private Sub サンプルK15()
'ω'部品割当リスト、在庫-使用数=残り、列追加
'ω'部品割当リスト、注残、列追加
'ω'部品割当リスト、残り+注残=注残分含残り、列追加
'ω'部品割当リスト、在庫+注残-割当引済=オーダ使用可、列追加

'ω'Worksheets("サンプルAデータリスト").Activate
Dim i As Long
Dim MR As Long
Dim X As String
Dim ws1 As Worksheet
Set ws1 = Worksheets("検デ")

ws1.Cells(1, 1).CurrentRegion.Name = "list1"
Dim SA As Range
Set SA = ws1.Range("list1")

MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B

AA = Range(Cells(1, 19), Cells(MR, 19))
XX = Range(Cells(1, 8), Cells(MR, 8))
For i = 2 To MR
X = XX(i, 1)
AA(i, 1) = Application.VLookup(X, SA, 4, False) 'ω'注残
Next i
Range(Cells(1, 19), Cells(MR, 19)) = AA

'ω'#N/A→0置換
'ω'MR = Cells(Rows.Count, 2).End(xlUp).Row 'ω'最終行,B:B
Range(Cells(1, 19), Cells(MR, 19)).Replace What:="#N/A", replacement:="0"

Dim M As Long, N As Long, Q As Long, R As Long, S As Long
MM = Range(Cells(1, 13), Cells(MR, 13))
NN = Range(Cells(1, 14), Cells(MR, 14))
QQ = Range(Cells(1, 17), Cells(MR, 17))
RR = Range(Cells(1, 18), Cells(MR, 18))
SS = Range(Cells(1, 19), Cells(MR, 19))
TT = Range(Cells(1, 20), Cells(MR, 20))
UU = Range(Cells(1, 21), Cells(MR, 21))
On Error Resume Next 'ω'#N/A無視
For i = 2 To MR
M = MM(i, 1)
N = NN(i, 1)
Q = QQ(i, 1)
RR(i, 1) = M - Q
R = RR(i, 1)
S = SS(i, 1)
TT(i, 1) = R + S
UU(i, 1) = M + S - N
Next i
On Error GoTo 0 'ω'#N/A無視解除
Range(Cells(1, 18), Cells(MR, 18)) = RR
Range(Cells(1, 20), Cells(MR, 20)) = TT
Range(Cells(1, 21), Cells(MR, 21)) = UU

'ω'部品割当リスト、MC最終列取得の為最後に項目追記
Cells(1, 17) = "使用数"
Cells(1, 18) = "残り"
Cells(1, 19) = "注残"
Cells(1, 20) = "注残含残り"
Cells(1, 21) = "オーダ使用可"

End Sub

Private Sub サンプルK16()
サンプルA09_1
End Sub

Private Sub サンプルK17()
サンプルA09_2
End Sub

Private Sub サンプルK18()
サンプルA09_3
End Sub

Private Sub サンプルK21()
サンプルA10
End Sub

Private Sub サンプルK22()
サンプルA11
End Sub

Sub サンプルK00()
'ω'サンプルKマクロ実行
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.AutoRecover.Enabled = False
Application.Calculation = xlCalculationManual

サンプルK01
サンプルK02
サンプルK04_1
サンプルK04_2
サンプルK05
サンプルK07
サンプルK08
サンプルK09
サンプルK10
サンプルK11
サンプルK12
サンプルK13
サンプルK14
サンプルK15
サンプルK16
サンプルK17
サンプルK18
サンプルK21
サンプルK22

Application.Calculation = xlCalculationAutomatic
Application.AutoRecover.Enabled = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.WindowState = xlNormal

End Sub