0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@akidenn_power

テスト投稿　プロトver

0
Posted at

Option Explicit

'========================================================
' ロット管理ツール（ひな形作成＋登録＋行増減）
' ※すべて Select 不要（フリーズも SplitRow方式）
'========================================================

'========================
' 入力画面（あなたの指定）
'========================
Private Const UI_SHEET As String = "入力"
Private Const CELL_ASM_DATE As String = "D6" ' 組込日
Private Const CELL_MACHINE1 As String = "B3" ' 1号機の値が入る
Private Const CELL_MACHINE2 As String = "E3" ' 2号機の値が入る

Private Const ROW_FIRST As Long = 11 ' 入力開始行
Private Const ROW_LAST As Long = 20 ' 入力終了行（最大10行）
Private Const ROW_SHOW5_LAST As Long = 15 ' 普段表示は11～15（5行）
Private Const ROW_EXTRA_FIRST As Long = 16 ' 追加行は16～20
Private Const ROW_EXTRA_LAST As Long = 20

' 部品A（左）
Private Const A_COL_MOLD As String = "B"
Private Const A_COL_MFG As String = "C"
Private Const A_COL_FROM As String = "D"
Private Const A_COL_TO As String = "F"

' 部品B（右）
Private Const B_COL_MOLD As String = "I"
Private Const B_COL_MFG As String = "J"
Private Const B_COL_FROM As String = "K"
Private Const B_COL_TO As String = "M"

' 出力シート名
Private Const SHEET_DETAIL As String = "明細"
Private Const SHEET_SUMMARY As String = "組合せ一覧"

'========================================================
' ひな形作成（入力/明細/組合せ一覧）＋ボタン＋5行表示
'========================================================
Public Sub ブックひな形_作成()
Application.ScreenUpdating = False
Application.EnableEvents = False

' --- 作り直し（同名は削除）
DeleteSheetIfExists UI_SHEET
DeleteSheetIfExists SHEET_DETAIL
DeleteSheetIfExists SHEET_SUMMARY

Dim wsUI As Worksheet, wsD As Worksheet, wsS As Worksheet
Set wsUI = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsUI.Name = UI_SHEET

Set wsD = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsD.Name = SHEET_DETAIL

Set wsS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsS.Name = SHEET_SUMMARY

SetupInputSheet wsUI
SetupDetailSheet wsD
SetupSummarySheet wsS

' ボタン作成（登録＋＋－）
CreateRegisterButton wsUI
CreatePlusMinusButtons wsUI

' 初期は5行表示
入力行_初期化_5行表示

' フリーズ固定（10行目より上を固定＝見出しが残る）
ApplyFreezePanes_NoSelect wsUI, 10

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "ひな形を作成したよ！" & vbCrLf & _
       "・入力 / 明細 / 組合せ一覧 を作成" & vbCrLf & _
       "・普段は5行表示（＋で10行）" & vbCrLf & _
       "・登録ボタンも配置済み", vbInformation

End Sub

'========================================================
' 入力シートレイアウト（必要セル位置を固定）
'========================================================
Private Sub SetupInputSheet(ByVal ws As Worksheet)
ws.Cells.Clear
ws.Cells.Font.Name = "Meiryo UI"

' 列幅（最低限）
ws.Columns("A").ColumnWidth = 3
ws.Columns("B").ColumnWidth = 10
ws.Columns("C").ColumnWidth = 12
ws.Columns("D").ColumnWidth = 10
ws.Columns("E").ColumnWidth = 3
ws.Columns("F").ColumnWidth = 10
ws.Columns("G").ColumnWidth = 3
ws.Columns("H").ColumnWidth = 3
ws.Columns("I").ColumnWidth = 10
ws.Columns("J").ColumnWidth = 12
ws.Columns("K").ColumnWidth = 10
ws.Columns("L").ColumnWidth = 3
ws.Columns("M").ColumnWidth = 10

' 1号機 / 2号機（B3 と E3 に値が入る想定）
ws.Range("B3:C4").Merge
ws.Range("B3:C4").Value = "1号機"
ws.Range("B3:C4").HorizontalAlignment = xlCenter
ws.Range("B3:C4").VerticalAlignment = xlCenter
ws.Range("B3:C4").Font.Bold = True
ws.Range("B3:C4").Interior.Color = RGB(243, 215, 235)
ws.Range("B3:C4").BorderAround Weight:=xlMedium

ws.Range("E3:F4").Merge
ws.Range("E3:F4").Value = "2号機"
ws.Range("E3:F4").HorizontalAlignment = xlCenter
ws.Range("E3:F4").VerticalAlignment = xlCenter
ws.Range("E3:F4").Font.Bold = True
ws.Range("E3:F4").Interior.Color = RGB(243, 215, 235)
ws.Range("E3:F4").BorderAround Weight:=xlMedium

' 組込日（D6）
ws.Range("B6:C6").Merge
ws.Range("B6:C6").Value = "組込み日"
ws.Range("B6:C6").HorizontalAlignment = xlCenter
ws.Range("B6:C6").Font.Bold = True
ws.Range("B6:C6").BorderAround Weight:=xlThin

ws.Range("D6:F6").Merge
ws.Range("D6:F6").NumberFormatLocal = "yyyy/m/d"
ws.Range("D6:F6").BorderAround Weight:=xlThin

' ---- 部品A（左）----
ws.Range("B9:F9").Merge
ws.Range("B9:F9").Value = "部品A"
ws.Range("B9:F9").HorizontalAlignment = xlCenter
ws.Range("B9:F9").Font.Bold = True
ws.Range("B9:F9").BorderAround Weight:=xlMedium

ws.Range("B10").Value = "金型"
ws.Range("C10").Value = "製造日"
ws.Range("D10").Value = "開始No"
ws.Range("E10").Value = "～"
ws.Range("F10").Value = "終了No"
ws.Range("B10:F10").Font.Bold = True
ws.Range("B10:F10").HorizontalAlignment = xlCenter

' ---- 部品B（右）----
ws.Range("I9:M9").Merge
ws.Range("I9:M9").Value = "部品B"
ws.Range("I9:M9").HorizontalAlignment = xlCenter
ws.Range("I9:M9").Font.Bold = True
ws.Range("I9:M9").BorderAround Weight:=xlMedium

ws.Range("I10").Value = "金型"
ws.Range("J10").Value = "製造日"
ws.Range("K10").Value = "開始No"
ws.Range("L10").Value = "～"
ws.Range("M10").Value = "終了No"
ws.Range("I10:M10").Font.Bold = True
ws.Range("I10:M10").HorizontalAlignment = xlCenter

Dim r As Long
For r = ROW_FIRST To ROW_LAST
    ' A入力
    ws.Range("B" & r).Interior.Color = RGB(243, 215, 235)  ' 金型
    ws.Range("C" & r).Interior.Color = RGB(221, 235, 247)  ' 製造日
    ws.Range("D" & r).Interior.Color = RGB(221, 235, 247)  ' 開始
    ws.Range("F" & r).Interior.Color = RGB(221, 235, 247)  ' 終了
    ws.Range("E" & r).Value = "～"
    ws.Range("E" & r).HorizontalAlignment = xlCenter

    ' B入力
    ws.Range("I" & r).Interior.Color = RGB(243, 215, 235)
    ws.Range("J" & r).Interior.Color = RGB(221, 235, 247)
    ws.Range("K" & r).Interior.Color = RGB(221, 235, 247)
    ws.Range("M" & r).Interior.Color = RGB(221, 235, 247)
    ws.Range("L" & r).Value = "～"
    ws.Range("L" & r).HorizontalAlignment = xlCenter
Next r

' 入力規則（金型）
AddValidationMold ws.Range("B11:B20")
AddValidationMold ws.Range("I11:I20")

' 日付形式
ws.Range("C11:C20").NumberFormatLocal = "yyyy/m/d"
ws.Range("J11:J20").NumberFormatLocal = "yyyy/m/d"

' 罫線
With ws.Range("B10:F20")
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlThin
End With
With ws.Range("I10:M20")
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlThin
End With

End Sub

Private Sub AddValidationMold(ByVal rng As Range)
On Error Resume Next
rng.Validation.Delete
On Error GoTo 0
rng.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
Formula1:="1型,2型"
rng.Validation.IgnoreBlank = True
rng.Validation.InCellDropdown = True
End Sub

'========================================================
' 明細シート初期化
'========================================================
Private Sub SetupDetailSheet(ByVal ws As Worksheet)
ws.Cells.Clear
ws.Cells.Font.Name = "Meiryo UI"

ws.Range("A1:K1").Value = Array( _
    "組込ID", "組込日", "機械", "部品", "金型", "製造日", "開始No", "終了No", "方向", "並び順", "件数" _
)
ws.Rows(1).Font.Bold = True
ws.Columns("A").ColumnWidth = 20
ws.Columns("B").ColumnWidth = 12
ws.Columns("C").ColumnWidth = 10
ws.Columns("D").ColumnWidth = 6
ws.Columns("E").ColumnWidth = 6
ws.Columns("F").ColumnWidth = 12
ws.Columns("G:K").ColumnWidth = 8

ws.Range("B:B").NumberFormatLocal = "yyyy/m/d"
ws.Range("F:F").NumberFormatLocal = "yyyy/m/d"

End Sub

'========================================================
' 組合せ一覧シート初期化
'========================================================
Private Sub SetupSummarySheet(ByVal ws As Worksheet)
ws.Cells.Clear
ws.Cells.Font.Name = "Meiryo UI"

ws.Range("A1:K1").Value = Array( _
    "組込ID", "組込日", "機械", _
    "A(1型)ロット群", "A(2型)ロット群", "B(1型)ロット群", "B(2型)ロット群", _
    "A合計", "B合計", "差分(B-A)", "判定" _
)
ws.Rows(1).Font.Bold = True
ws.Columns("A").ColumnWidth = 20
ws.Columns("B").ColumnWidth = 12
ws.Columns("C").ColumnWidth = 10
ws.Columns("D:G").ColumnWidth = 42
ws.Columns("H:K").ColumnWidth = 12

ws.Range("B:B").NumberFormatLocal = "yyyy/m/d"

End Sub

'========================================================
' ボタン作成（登録）
'========================================================
Private Sub CreateRegisterButton(ByVal ws As Worksheet)
Dim btn As Shape

On Error Resume Next
ws.Shapes("btnRegister").Delete
On Error GoTo 0

Set btn = ws.Shapes.AddFormControl(Type:=xlButtonControl, _
                                   Left:=ws.Range("H19").Left, _
                                   Top:=ws.Range("H19").Top, _
                                   Width:=ws.Range("J20").Left - ws.Range("H19").Left, _
                                   Height:=ws.Range("H19").Height * 2)
btn.Name = "btnRegister"
btn.TextFrame.Characters.Text = "登録"

On Error GoTo AssignFail
btn.OnAction = "登録_明細と組合せ一覧_追記"
Exit Sub

AssignFail:
MsgBox "登録ボタンは作ったけど、マクロ割り当てに失敗したかも。" & vbCrLf & _
"右クリック→マクロの登録 で「登録_明細と組合せ一覧_追記」を選んでね。", vbExclamation
End Sub

'========================================================
' ボタン作成（＋／－）
'========================================================
Private Sub CreatePlusMinusButtons(ByVal ws As Worksheet)
Dim btnP As Shape, btnM As Shape

On Error Resume Next
ws.Shapes("btnPlus").Delete
ws.Shapes("btnMinus").Delete
On Error GoTo 0

' ＋（B16）
Set btnP = ws.Shapes.AddFormControl(Type:=xlButtonControl, _
                                    Left:=ws.Range("B16").Left, _
                                    Top:=ws.Range("B16").Top, _
                                    Width:=ws.Range("B16").Width, _
                                    Height:=ws.Range("B16").Height)
btnP.Name = "btnPlus"
btnP.TextFrame.Characters.Text = "＋"
On Error GoTo PlusAssignFail
btnP.OnAction = "入力行_増やす_10行表示"
On Error GoTo 0

' －（C16）
Set btnM = ws.Shapes.AddFormControl(Type:=xlButtonControl, _
                                    Left:=ws.Range("C16").Left, _
                                    Top:=ws.Range("C16").Top, _
                                    Width:=ws.Range("C16").Width, _
                                    Height:=ws.Range("C16").Height)
btnM.Name = "btnMinus"
btnM.TextFrame.Characters.Text = "－"
On Error GoTo MinusAssignFail
btnM.OnAction = "入力行_戻す_5行表示_追加行クリア"
On Error GoTo 0

Exit Sub

PlusAssignFail:
MsgBox "＋ボタンの割り当てに失敗したかも。右クリック→マクロの登録で「入力行_増やす_10行表示」を選んでね。", vbExclamation
Resume Next

MinusAssignFail:
MsgBox "－ボタンの割り当てに失敗したかも。右クリック→マクロの登録で「入力行_戻す_5行表示_追加行クリア」を選んでね。", vbExclamation
Resume Next
End Sub

'========================================================
' 入力行の表示制御（普段5行／＋で10行）
'========================================================
Public Sub 入力行_初期化_5行表示()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(UI_SHEET)
ws.Rows(ROW_EXTRA_FIRST & ":" & ROW_EXTRA_LAST).Hidden = True
End Sub

Public Sub 入力行_増やす_10行表示()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(UI_SHEET)
ws.Rows(ROW_EXTRA_FIRST & ":" & ROW_EXTRA_LAST).Hidden = False
End Sub

Public Sub 入力行_戻す_5行表示_追加行クリア()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(UI_SHEET)

' 追加行だけ消す（A: B,C,D,F / B: I,J,K,M）
ws.Range("B16:B20,C16:C20,D16:D20,F16:F20").ClearContents
ws.Range("I16:I20,J16:J20,K16:K20,M16:M20").ClearContents

ws.Rows(ROW_EXTRA_FIRST & ":" & ROW_EXTRA_LAST).Hidden = True

End Sub

'========================================================
' フリーズ固定（完全ノーSelect）
' freezeRow=10 → 9行目まで固定
'========================================================
Private Sub ApplyFreezePanes_NoSelect(ByVal ws As Worksheet, ByVal freezeRow As Long)
Dim wnd As Window
Set wnd = ws.Parent.Windows(1)

ws.Activate
wnd.FreezePanes = False
wnd.SplitRow = freezeRow - 1
wnd.SplitColumn = 0
wnd.FreezePanes = True

End Sub

'========================================================
' 登録（入力→明細追記→組合せ一覧追記）
'========================================================
Public Sub 登録_明細と組合せ一覧_追記()
Dim wsUI As Worksheet
Set wsUI = ThisWorkbook.Worksheets(UI_SHEET)

Dim asmDate As Variant
asmDate = wsUI.Range(CELL_ASM_DATE).Value
If Not IsDate(asmDate) Then
    MsgBox "組込み日(D6)が日付になってないよ。", vbExclamation
    Exit Sub
End If

Dim machineName As String
machineName = GetMachineName(wsUI)
If machineName = "" Then
    MsgBox "機械(1号機/2号機)が選択されてないみたい。B3かE3に値が入る想定だよ。", vbExclamation
    Exit Sub
End If

Dim wsD As Worksheet, wsS As Worksheet
Set wsD = EnsureSheet(SHEET_DETAIL)
Set wsS = EnsureSheet(SHEET_SUMMARY)

EnsureHeaders wsD, wsS

' 組込ID（同日同機械が重複したら連番）
Dim asmID As String
asmID = BuildAsmID(wsD, CDate(asmDate), machineName)

' 集計用（入力順保持）
Dim lotA1 As Collection, lotA2 As Collection, lotB1 As Collection, lotB2 As Collection
Set lotA1 = New Collection
Set lotA2 = New Collection
Set lotB1 = New Collection
Set lotB2 = New Collection

Dim cntA As Long, cntB As Long
cntA = 0: cntB = 0

Dim wrote As Long
wrote = 0

Application.ScreenUpdating = False
Application.EnableEvents = False

' 部品A（左）
wrote = wrote + ReadBlockAndAppend(wsUI, wsD, asmID, CDate(asmDate), machineName, _
                                  "A", A_COL_MOLD, A_COL_MFG, A_COL_FROM, A_COL_TO, _
                                  lotA1, lotA2, cntA)

' 部品B（右）
wrote = wrote + ReadBlockAndAppend(wsUI, wsD, asmID, CDate(asmDate), machineName, _
                                  "B", B_COL_MOLD, B_COL_MFG, B_COL_FROM, B_COL_TO, _
                                  lotB1, lotB2, cntB)

If wrote = 0 Then
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "入力が空みたい。部品A/Bのどれか1行は入れてね。", vbExclamation
    Exit Sub
End If

' 組合せ一覧へ追記
AppendSummaryRow wsS, asmID, CDate(asmDate), machineName, _
                 JoinLots(lotA1), JoinLots(lotA2), JoinLots(lotB1), JoinLots(lotB2), _
                 cntA, cntB

' 登録後：D6だけ残して他はクリア（機械も消す）
ClearInputAfterRegister_KeepDateOnly

MsgBox "登録完了！  組込ID=" & asmID, vbInformation

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "登録完了！  組込ID=" & asmID, vbInformation

End Sub

'------------------------
' 部品ブロック読取り → 明細追記
'------------------------
Private Function ReadBlockAndAppend(ByVal wsUI As Worksheet, ByVal wsD As Worksheet, _
ByVal asmID As String, ByVal asmDate As Date, ByVal machineName As String, _
ByVal partName As String, _
ByVal colMold As String, ByVal colMfg As String, ByVal colFrom As String, ByVal colTo As String, _
ByVal lot1 As Collection, ByVal lot2 As Collection, ByRef partTotal As Long) As Long
Dim r As Long
Dim wrote As Long: wrote = 0

Dim seq1 As Long: seq1 = 0
Dim seq2 As Long: seq2 = 0

For r = ROW_FIRST To ROW_LAST
    Dim vMold As String
    vMold = Trim(CStr(wsUI.Range(colMold & r).Value))

    Dim vMfg As Variant
    vMfg = wsUI.Range(colMfg & r).Value

    Dim vFrom As Variant, vTo As Variant
    vFrom = wsUI.Range(colFrom & r).Value
    vTo = wsUI.Range(colTo & r).Value

    ' 行が完全に空ならスキップ
    If vMold = "" And Trim(CStr(vMfg)) = "" And Trim(CStr(vFrom)) = "" And Trim(CStr(vTo)) = "" Then
        GoTo ContinueNext
    End If

    ' 金型（"1型"/"2型"/1/2）
    Dim moldNo As Long
    moldNo = ParseMoldNo(vMold)
    If moldNo <> 1 And moldNo <> 2 Then
        MsgBox "金型の指定が不正かも。部品" & partName & " 行" & r & " の金型=" & vMold, vbExclamation
        GoTo ContinueNext
    End If

    ' 製造日
    If Not IsDate(vMfg) Then
        MsgBox "製造日が日付になってないよ。部品" & partName & " 行" & r, vbExclamation
        GoTo ContinueNext
    End If

    ' ケースNo
    If (Not IsNumeric(vFrom)) Or (Not IsNumeric(vTo)) Then
        MsgBox "ケースNoが数値じゃないよ。部品" & partName & " 行" & r, vbExclamation
        GoTo ContinueNext
    End If

    Dim nFrom As Long, nTo As Long
    nFrom = CLng(vFrom): nTo = CLng(vTo)

    If nFrom < 1 Or nFrom > 99 Or nTo < 1 Or nTo > 99 Then
        MsgBox "ケースNoは1～99想定。部品" & partName & " 行" & r & " (" & nFrom & "～" & nTo & ")", vbExclamation
        GoTo ContinueNext
    End If

    Dim dir As String
    dir = IIf(nFrom <= nTo, "↑", "↓") ' 21～5は↓（順番の意味を保持）

    Dim qty As Long
    qty = Abs(nFrom - nTo) + 1 ' 循環は分割入力される運用なのでこれでOK

    ' 並び順（入力順が大事）
    Dim seq As Long
    If moldNo = 1 Then
        seq1 = seq1 + 1
        seq = seq1
    Else
        seq2 = seq2 + 1
        seq = seq2
    End If

    ' ロット群の表示（入力順保持）
    Dim seg As String
    seg = Format(CDate(vMfg), "yyyy/m/d") & ":" & nFrom & "-" & nTo & "(" & dir & ")"

    If moldNo = 1 Then
        lot1.Add seg
    Else
        lot2.Add seg
    End If

    partTotal = partTotal + qty

    ' 明細へ追記
    AppendDetailRow wsD, asmID, asmDate, machineName, partName, moldNo, CDate(vMfg), nFrom, nTo, dir, seq, qty

    wrote = wrote + 1

ContinueNext:
Next r

ReadBlockAndAppend = wrote

End Function

Private Sub AppendDetailRow(ByVal wsD As Worksheet, ByVal asmID As String, ByVal asmDate As Date, _
ByVal machineName As String, ByVal partName As String, ByVal moldNo As Long, _
ByVal mfgDate As Date, ByVal nFrom As Long, ByVal nTo As Long, _
ByVal dir As String, ByVal seq As Long, ByVal qty As Long)
Dim lr As Long
lr = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row + 1

wsD.Cells(lr, 1).Value = asmID
wsD.Cells(lr, 2).Value = asmDate
wsD.Cells(lr, 3).Value = machineName
wsD.Cells(lr, 4).Value = partName
wsD.Cells(lr, 5).Value = moldNo
wsD.Cells(lr, 6).Value = mfgDate
wsD.Cells(lr, 7).Value = nFrom
wsD.Cells(lr, 8).Value = nTo
wsD.Cells(lr, 9).Value = dir
wsD.Cells(lr, 10).Value = seq
wsD.Cells(lr, 11).Value = qty

End Sub

Private Sub AppendSummaryRow(ByVal wsS As Worksheet, ByVal asmID As String, ByVal asmDate As Date, ByVal machineName As String, _
ByVal a1 As String, ByVal a2 As String, ByVal b1 As String, ByVal b2 As String, _
ByVal cntA As Long, ByVal cntB As Long)
Dim lr As Long
lr = wsS.Cells(wsS.Rows.Count, 1).End(xlUp).Row + 1

wsS.Cells(lr, 1).Value = asmID
wsS.Cells(lr, 2).Value = asmDate
wsS.Cells(lr, 3).Value = machineName
wsS.Cells(lr, 4).Value = a1
wsS.Cells(lr, 5).Value = a2
wsS.Cells(lr, 6).Value = b1
wsS.Cells(lr, 7).Value = b2
wsS.Cells(lr, 8).Value = cntA
wsS.Cells(lr, 9).Value = cntB
wsS.Cells(lr, 10).Value = cntB - cntA
wsS.Cells(lr, 11).Value = IIf(cntA = cntB, "OK", "⚠不一致")

End Sub

'========================================================
' ヘッダ保証（登録が先に走ってもOK）
'========================================================
Private Sub EnsureHeaders(ByVal wsD As Worksheet, ByVal wsS As Worksheet)
If wsD.Cells(1, 1).Value = "" Then SetupDetailSheet wsD
If wsS.Cells(1, 1).Value = "" Then SetupSummarySheet wsS
End Sub

'========================================================
' ユーティリティ
'========================================================
Private Function GetMachineName(ByVal ws As Worksheet) As String
Dim v1 As String, v2 As String
v1 = Trim(CStr(ws.Range(CELL_MACHINE1).Value))
v2 = Trim(CStr(ws.Range(CELL_MACHINE2).Value))

If v1 <> "" And v2 = "" Then
    GetMachineName = v1
ElseIf v2 <> "" And v1 = "" Then
    GetMachineName = v2
ElseIf v1 <> "" And v2 <> "" Then
    GetMachineName = v1 ' 両方入ってたらB3優先
Else
    GetMachineName = ""
End If

End Function

Private Function ParseMoldNo(ByVal s As String) As Long
s = Replace(s, "型", "")
s = Trim$(s)
If IsNumeric(s) Then
ParseMoldNo = CLng(s)
Else
ParseMoldNo = 0
End If
End Function

Private Function EnsureSheet(ByVal name As String) As Worksheet
On Error Resume Next
Set EnsureSheet = ThisWorkbook.Worksheets(name)
On Error GoTo 0
If EnsureSheet Is Nothing Then
Set EnsureSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
EnsureSheet.Name = name
End If
End Function

Private Function BuildAsmID(ByVal wsD As Worksheet, ByVal asmDate As Date, ByVal machineName As String) As String
Dim baseID As String
baseID = Format(asmDate, "yyyymmdd") & "_" & machineName

Dim lastRow As Long: lastRow = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row
Dim i As Long, maxN As Long: maxN = 0

For i = 2 To lastRow
    Dim id As String: id = CStr(wsD.Cells(i, 1).Value)
    If Left$(id, Len(baseID)) = baseID Then
        Dim p As Long: p = InStr(id, "-")
        If p > 0 Then
            Dim n As Long
            n = Val(Mid$(id, p + 1))
            If n > maxN Then maxN = n
        Else
            If maxN < 1 Then maxN = 1
        End If
    End If
Next i

If maxN = 0 Then
    BuildAsmID = baseID
Else
    BuildAsmID = baseID & "-" & Format(maxN + 1, "000")
End If

End Function

Private Function JoinLots(ByVal col As Collection) As String
If col.Count = 0 Then
JoinLots = ""
Exit Function
End If

Dim i As Long, s As String
For i = 1 To col.Count
    If i = 1 Then
        s = CStr(col(i))
    Else
        s = s & " / " & CStr(col(i))
    End If
Next i
JoinLots = s

End Function

Private Sub DeleteSheetIfExists(ByVal name As String)
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(name)
On Error GoTo 0
If ws Is Nothing Then Exit Sub

Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True

End Sub

'========================================================
' 入力クリア（登録後用）：D6だけ残す／機械は消す
'========================================================
Private Sub ClearInputAfterRegister_KeepDateOnly()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(UI_SHEET)

Application.EnableEvents = False

' 機械クリア（B3/E3）
ws.Range(CELL_MACHINE1).ClearContents
ws.Range(CELL_MACHINE2).ClearContents

' 入力欄クリア（A側：B,C,D,F / B側：I,J,K,M）
ws.Range("B11:B20,C11:C20,D11:D20,F11:F20").ClearContents
ws.Range("I11:I20,J11:J20,K11:K20,M11:M20").ClearContents

' 追加行を閉じる（普段は5行）
ws.Rows(ROW_EXTRA_FIRST & ":" & ROW_EXTRA_LAST).Hidden = True

Application.EnableEvents = True

End Sub

'========================================================
' 入力クリア（起動時/完全リセット）：D6含め全部消す
'========================================================
Public Sub ClearInput_All()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(UI_SHEET)
On Error GoTo 0
If ws Is Nothing Then Exit Sub

Application.EnableEvents = False

' 組込日もクリア
ws.Range(CELL_ASM_DATE).ClearContents

' 機械もクリア
ws.Range(CELL_MACHINE1).ClearContents
ws.Range(CELL_MACHINE2).ClearContents

' 入力欄クリア
ws.Range("B11:B20,C11:C20,D11:D20,F11:F20").ClearContents
ws.Range("I11:I20,J11:J20,K11:K20,M11:M20").ClearContents

' 追加行を閉じる（普段は5行）
ws.Rows(ROW_EXTRA_FIRST & ":" & ROW_EXTRA_LAST).Hidden = True

Application.EnableEvents = True

End Sub

'========================================================
' ロット検索：このロット（製造日＋ケースNo）がどこで使われた？
' 結果は「検索結果」シートに出力
'========================================================
Public Sub ロット検索_どこに使われた()
Dim wsD As Worksheet
On Error Resume Next
Set wsD = ThisWorkbook.Worksheets(SHEET_DETAIL)
On Error GoTo 0
If wsD Is Nothing Then
MsgBox "「明細」シートが見つからないよ。先に登録してデータ作ってね。", vbExclamation
Exit Sub
End If

Dim sDate As String
sDate = InputBox("製造日を入力（例：2026/2/13）" & vbCrLf & "※空欄なら製造日は条件にしない", "ロット検索")

Dim useDate As Boolean
Dim targetDate As Date
useDate = False
If Trim$(sDate) <> "" Then
    If Not IsDate(sDate) Then
        MsgBox "製造日が日付として認識できないよ：" & sDate, vbExclamation
        Exit Sub
    End If
    targetDate = CDate(sDate)
    useDate = True
End If

Dim sNo As String
sNo = InputBox("ケースNo（1～99の数字）を入力", "ロット検索")
If Trim$(sNo) = "" Then Exit Sub
If Not IsNumeric(sNo) Then
    MsgBox "ケースNoは数字で入力してね。", vbExclamation
    Exit Sub
End If

Dim targetNo As Long
targetNo = CLng(sNo)
If targetNo < 1 Or targetNo > 99 Then
    MsgBox "ケースNoは1～99だよ。", vbExclamation
    Exit Sub
End If

' 出力先
Dim wsR As Worksheet
Set wsR = EnsureSheet("検索結果")
wsR.Cells.Clear
wsR.Cells.Font.Name = "Meiryo UI"

' ヘッダ（明細と同じ）
wsR.Range("A1:K1").Value = Array( _
    "組込ID", "組込日", "機械", "部品", "金型", "製造日", "開始No", "終了No", "方向", "並び順", "件数" _
)
wsR.Rows(1).Font.Bold = True
wsR.Columns("A").ColumnWidth = 20
wsR.Columns("B").ColumnWidth = 12
wsR.Columns("C").ColumnWidth = 10
wsR.Columns("D").ColumnWidth = 6
wsR.Columns("E").ColumnWidth = 6
wsR.Columns("F").ColumnWidth = 12
wsR.Columns("G:K").ColumnWidth = 8
wsR.Range("B:B").NumberFormatLocal = "yyyy/m/d"
wsR.Range("F:F").NumberFormatLocal = "yyyy/m/d"

Dim lastRow As Long
lastRow = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then
    MsgBox "明細にデータがまだ無いよ。", vbExclamation
    Exit Sub
End If

Dim r As Long, outRow As Long
outRow = 2

For r = 2 To lastRow
    ' 明細列
    Dim mfg As Variant
    mfg = wsD.Cells(r, 6).Value ' 製造日

    If useDate Then
        If Not IsDate(mfg) Then GoTo NextR
        If CDate(mfg) <> targetDate Then GoTo NextR
    End If

    Dim nFrom As Variant, nTo As Variant
    nFrom = wsD.Cells(r, 7).Value
    nTo = wsD.Cells(r, 8).Value
    If Not IsNumeric(nFrom) Or Not IsNumeric(nTo) Then GoTo NextR

    Dim a As Long, b As Long, lo As Long, hi As Long
    a = CLng(nFrom): b = CLng(nTo)
    lo = IIf(a < b, a, b)
    hi = IIf(a > b, a, b)

    ' このレンジに targetNo が含まれるか
    If targetNo < lo Or targetNo > hi Then GoTo NextR

    ' ヒット：行コピー
    wsR.Range("A" & outRow & ":K" & outRow).Value = wsD.Range("A" & r & ":K" & r).Value
    outRow = outRow + 1

NextR:
Next r

If outRow = 2 Then
    MsgBox "該当なし。" & vbCrLf & _
           IIf(useDate, "製造日=" & Format$(targetDate, "yyyy/m/d") & ", ", "") & _
           "ケースNo=" & targetNo, vbInformation
Else
    MsgBox "検索結果：" & (outRow - 2) & "件ヒットしたよ（検索結果シートに出した）", vbInformation
End If

End Sub

thisworksheetへ
Private Sub Workbook_Open()
' ブックを開いたら入力欄を全クリア（D6も含めて）
ClearInput_All
End Sub

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?