Sub 罫線トグル()
Application.ScreenUpdating = False
asn = ActiveSheet.Name
Dim sc As Integer ' シート数
sc = ActiveWorkbook.Sheets.Count
ReDim sn(sc, 2) As String 'シート名,フォーム数
For i = 1 To sc Step 1
If Sheets(i).Name <> "集計" Then
sn(i, 1) = Sheets(i).Name
sn(i, 2) = fcount(Sheets(i).Name)
If sn(i, 2) = -1 Then
MsgBox sn(i, 1) & "シートが適切な工程表ではないため罫線の描画ができません。"
Exit Sub
End If
End If
Next i
If Sheets(1).Range("H5").Borders(xlEdgeRight).LineStyle = -4142 Then '罫線無し
borderState = False
ElseIf Sheets(1).Range("H5").Borders(xlEdgeRight).LineStyle = -4118 Then '罫線有り
borderState = True
End If
For i = 1 To sc Step 1
Call BorderToggle(sn(i, 1), sn(i, 2), borderState) 'シート名,フォーム数
Next i
Sheets(asn).Activate
Application.ScreenUpdating = True
MsgBox "終了しました。"
End Sub
Sub BorderToggle(sheetName, formQty, borderState)
If sheetName = "" Then Exit Sub
With Sheets(sheetName)
If borderState = True Then '罫線有り
rowTop = 5
rowBtn = 24
For f = 1 To formQty
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders.LineStyle = xlLineStyleNone
'斜線は個別に処理しないと消えなかった。
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlDiagonalDown).LineStyle = -4142
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlDiagonalUp).LineStyle = -4142
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlEdgeTop).LineStyle = 1
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlEdgeRight).LineStyle = 1
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlEdgeBottom).LineStyle = 1
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlEdgeLeft).LineStyle = 1
rowTop = rowTop + 25
rowBtn = rowBtn + 25
Next f
End If
If borderState = False Then '罫線無し
rowTop = 5
rowBtn = 24
For f = 1 To formQty
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlInsideVertical).LineStyle = -4118
.Range(.Cells(rowTop, 8), .Cells(rowBtn, 100)).Borders(xlInsideHorizontal).LineStyle = 1
'縦のWeightが違う線の処理
For col = 10 To 97 Step 3
.Range(.Cells(rowTop, col), .Cells(rowBtn, col)).Borders(xlEdgeRight).LineStyle = 1
Select Case col
Case 22, 40, 55, 70, 85
.Range(.Cells(rowTop, col), .Cells(rowBtn, col)).Borders(xlEdgeRight).Weight = -4138
End Select
Next col
For col = 8 To 38 Step 3
'月末部の斜線処理
If .Cells(4, col).Value = "" Then
.Range(.Cells(rowTop, col), .Cells(rowBtn, col + 2)).Borders(xlDiagonalUp).LineStyle = 1
End If
Next col
rowTop = rowTop + 25
rowBtn = rowBtn + 25
Next f
End If
End With
End Sub
Sub 生産高集計()
'[集計]というシートがあると削除
'個別シートのフォーム数はA列で判断
'（24なら1つ49なら2つというように探す、フォームが崩れているとエラーを返す）
'B列が記入されていて、尚且つ[数量]と[単価]が記入されている行のみ処理
'日付はG列に記入があれば、そちらを使用、なければF列を使用
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name = "集計" Then
If vbYes = MsgBox("集計シートが存在します。削除しますか？", vbYesNo) Then
Worksheets("集計").Delete
Else
Exit Sub
End If
End If
Next ws
Dim sc As Integer ' シート数
sc = ActiveWorkbook.Sheets.Count
ReDim sn(sc, 2) As String 'シート名,フォーム数
For i = 1 To sc Step 1
sn(i, 1) = Sheets(i).Name
sn(i, 2) = fcount(sn(i, 1)) ' fcount call
If sn(i, 2) = -1 Then
MsgBox sn(i, 1) & "シートが適切な工程表ではないため集計できません。"
Exit Sub
End If
Next i
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "集計"
If 納期集計(sn(1, 1)) = -1 Then Exit Sub '納期集計 call
For i = 1 To sc Step 1
Call main(sn(i, 1), sn(i, 2), i) 'シート名,フォーム数,カウンタ
Call main2(sn(i, 1), sn(i, 2), i) 'シート名,フォーム数,カウンタ
Next i
With Sheets("集計")
.Range("J1").Value = "班名"
.Range("K1").Value = "生産額"
.Range("L1").Value = "目盛"
.Range("M1").Value = "生産日数"
.Range("N1").Value = "生産額/日"
.Range("P1").Value = "目盛"
.Range("Q1").Value = "未生産日数"
.Columns("A:Q").AutoFit
.Activate
End With
Application.ScreenUpdating = True
MsgBox "終了しました。"
End Sub
Sub main(ByVal sn As String, ByVal fc As Integer, ByVal c As Integer) 'シート名,フォーム数,カウンタ
Worksheets("集計").Cells(c, 1).Value = sn
Worksheets("集計").Cells(c + 1, 10).Value = sn
Worksheets(sn).Activate
buf = 0
For r = (fc * 25 - 1) To 5 Step -1 '-
If ActiveSheet.Range("B" & r & "").Value <> "" Then '型式が記入されている '--
'ActiveSheet.Range("B" & r & "").Select
If IsNumeric(ActiveSheet.Range("E" & r & "").Value) And IsNumeric(ActiveSheet.Range("CZ" & r & "").Value) Then '数量と単価が数値 '---
buf = buf + (ActiveSheet.Range("E" & r & "").Value * ActiveSheet.Range("CZ" & r & "").Value)
'ここから顧客別金額 -------------------------------------------------
If ActiveSheet.Range("CX" & r & "").Value = "" Then
cus = "空白"
Else
cus = 文字列調整(ActiveSheet.Range("CX" & r & "").Value)
End If
pri = ActiveSheet.Range("E" & r & "").Value * ActiveSheet.Range("CZ" & r & "").Value
i = 1
Do While Worksheets("集計").Range("D" & i & "").Value <> ""
If Worksheets("集計").Range("D" & i & "").Value = cus Then
Worksheets("集計").Range("E" & i & "").NumberFormatLocal = "#,##0"
Worksheets("集計").Range("E" & i & "").Value = Worksheets("集計").Range("E" & i & "").Value + pri
pri = 0
End If
i = i + 1
Loop
If pri <> 0 Then
Worksheets("集計").Range("D" & i & "").Value = cus
Worksheets("集計").Range("E" & i & "").NumberFormatLocal = "#,##0"
Worksheets("集計").Range("E" & i & "").Value = pri
End If
'ここまで顧客別金額 ここから納期別金額 -------------------------------------------------
lt = ActiveSheet.Range("F" & r & "").Value
If ActiveSheet.Range("G" & r & "").Value <> "" Then lt = ActiveSheet.Range("G" & r & "").Value
If IsDate(lt) = False Then
Worksheets("集計").Range("H13").NumberFormatLocal = "#,##0"
Worksheets("集計").Range("H13").Value = Worksheets("集計").Range("H13").Value + (ActiveSheet.Range("E" & r & "").Value * ActiveSheet.Range("CZ" & r & "").Value)
End If
If IsDate(lt) Then
m = Month(lt)
d = Day(lt)
Select Case d
Case 21 To 31
m = m + 1
If m = 13 Then m = 1
Case 1 To 20
End Select
For i = 1 To 12
If m = Worksheets("集計").Range("G" & i & "").Value Then
Worksheets("集計").Range("H" & i & "").NumberFormatLocal = "#,##0"
Worksheets("集計").Range("H" & i & "").Value = Worksheets("集計").Range("H" & i & "").Value + (ActiveSheet.Range("E" & r & "").Value * ActiveSheet.Range("CZ" & r & "").Value)
End If
Next i
End If
'ここまで納期別金額 -------------------------------------------------
End If '---
End If '--
Select Case r
Case 105, 80, 55, 30
r = r - 5
End Select
Next r ' -
Worksheets("集計").Cells(c, 2).NumberFormatLocal = "#,##0"
Worksheets("集計").Cells(c, 2).Value = buf
Worksheets("集計").Cells(c + 1, 11).NumberFormatLocal = "#,##0"
Worksheets("集計").Cells(c + 1, 11).Value = buf
End Sub
Function fcount(ByVal sn As String) As Integer
Dim rc As Integer '行数
Dim fc As Integer 'フォーム数
Sheets(sn).Activate
rc = ActiveSheet.UsedRange.Rows.Count
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 'フォーム数を確認(A列で判断)
If Range("A" & i & "").Value <> "" Then Exit For
Next i
Select Case i
Case 24
fc = 1
Case 49
fc = 2
Case 74
fc = 3
Case 99
fc = 4
Case 124
fc = 5
Case Else
fc = -1
End Select
fcount = fc
End Function
Function 文字列調整(ByVal cus_str As String)
cus_str = Replace(cus_str, vbLf, "")
cus_str = StrConv(cus_str, vbWide)
cus_str = Replace(cus_str, " ", " ") '空白4つまで1つに置換する
cus_str = Replace(cus_str, " ", " ")
cus_str = Trim(cus_str)
cus_str = Replace(cus_str, "㈱", "")
cus_str = Replace(cus_str, "㈲", "")
文字列調整 = cus_str
End Function
Function 納期集計(ByVal sn As String)
mth = Replace(Sheets(sn).Range("H2").Value, "月", "")
Select Case mth
Case 1 To 12
For i = 1 To 12
Sheets("集計").Range("G" & i & "").Value = mth + i
If Sheets("集計").Range("G" & i & "").Value > 12 Then
Sheets("集計").Range("G" & i & "").Value = Sheets("集計").Range("G" & i & "").Value - 12
End If
Next i
Case Else
MsgBox "月が正しく記入されていません。"
mth = -1
End Select
Sheets("集計").Range("G13").Value = "未定"
納期集計 = mth
End Function
Sub main2(ByVal sn As String, ByVal fc As Integer, ByVal c As Integer) 'シート名,フォーム数,カウンタ
Worksheets(sn).Activate
buf1 = 0
buf2 = 0
For cc = 8 To 100
For r = 5 To (fc * 25 - 1)
If ActiveSheet.Cells(4, cc).Interior.Color = RGB(255, 255, 0) Then Exit For
If ActiveSheet.Cells(r, cc).Interior.Color = RGB(0, 0, 0) Then
buf1 = buf1 + 1 '黒塗りつぶし
Exit For
End If
'ActiveSheet.Cells(r, cc).Value = r & "," & cc
If r = (fc * 25 - 1) Then buf2 = buf2 + 1 '塗りつぶしなし
Select Case r
Case 99, 74, 49, 24
r = r + 5
End Select
Next r
Next cc
Worksheets("集計").Cells(c + 1, 12).Value = buf1 '目盛
Worksheets("集計").Cells(c + 1, 13).NumberFormatLocal = "0.0" '
Worksheets("集計").Cells(c + 1, 13).Value = buf1 / 3 '生産日数
Worksheets("集計").Cells(c + 1, 14).NumberFormatLocal = "#,##0"
If Worksheets("集計").Cells(c + 1, 13) <> 0 Then
Worksheets("集計").Cells(c + 1, 14).Value = (Worksheets("集計").Cells(c + 1, 11)) / (Worksheets("集計").Cells(c + 1, 13)) '生産額/日
End If
Worksheets("集計").Cells(c + 1, 16).Value = buf2
Worksheets("集計").Cells(c + 1, 17).NumberFormatLocal = "0.0" '
Worksheets("集計").Cells(c + 1, 17).Value = buf2 / 3 '未生産日数
End Sub
