Option Explicit
Const StartRow As Long = 6          'データ開始行(1以上を指定)
Const BubanCol As String = "E"      '部番列
Const OutColTbl As String = "L,O,R,U,X,AA,AD,AG,AJ,AM,AP,AS,AV,AY,BB,BE"       '-出力対象列
Public Sub 納品対象外部品()
    Dim bias As Long
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim wrow As Long
    Dim no_blk As Long
    Dim str As String
    Dim bno As Long
    Dim ino As Long
    Dim outcols As Variant
    outcols = Split(OutColTbl, ",")
    bias = StartRow - 1
    Set ws = ActiveSheet
    lastRow = ws.Cells(Rows.Count, BubanCol).End(xlUp).row
    If lastRow < (bias + 3) Or (lastRow - bias) Mod 3 <> 0 Then
        Call error(ws, lastRow, "最終行不正")
    End If
    no_blk = (lastRow - bias) \ 3
    Call clear_out_cols(ws, StartRow, lastRow, outcols)   '全ての出力対象列をクリア
    For bno = 1 To no_blk
        Dim rowA As Long: rowA = 0
        Dim rowB As Long: rowB = 0
        Dim rowH As Long: rowH = 0
        Dim row_mark As Long: row_mark = 0
        Dim pv_wd As String: pv_wd = ""
        Dim en_wd As String
        For ino = 1 To 3
            wrow = bias + (bno - 1) * 3 + ino
            str = ws.Cells(wrow, BubanCol).Value
            Dim wd As String
            Select Case Right(str, 1)
            Case "A"
                If rowA <> 0 Then Call error(ws, wrow, "終端文字Aが2回出現")
                rowA = wrow
                wd = Left(str, Len(str) - 1)
            Case "B"
                If rowB <> 0 Then Call error(ws, wrow, "終端文字Bが2回出現")
                rowB = wrow
                wd = Left(str, Len(str) - 1)
            Case "H"
                If rowH <> 0 Then Call error(ws, wrow, "終端文字Hが2回出現")
                rowH = wrow
                en_wd = Right(str, 2)
                Select Case en_wd
                Case "AH"
                Case "BH"
                Case Else
                    Call error(ws, wrow, "終端文字がAH,BHの何れかでない")
                End Select
                wd = Left(str, Len(str) - 2)
            Case Else
                Call error(ws, wrow, "終端文字がA,B,Hの何れかでない")
            End Select
            If Len(wd) = 0 Then Call error(ws, wrow, "部番の共通文字が空")
            If pv_wd = "" Then
                pv_wd = wd
            Else
                If pv_wd <> wd Then Call error(ws, wrow, "部番の共通文字が不一致")
            End If
        Next
        If en_wd = "AH" Then row_mark = rowA
        If en_wd = "BH" Then row_mark = rowB
        If row_mark = 0 Then Call error(ws, wrow, "納品対象外行が決定できない")
        Call set_out_cols(ws, row_mark, outcols)    '全ての出力対象列へ-設定
    Next
    MsgBox ("完了")
End Sub
'全出力対象列をクリア
Private Sub clear_out_cols(ws As Worksheet, ByVal st As Long, ByVal en As Long, outcols As Variant)
    Dim ocol As Variant
    For Each ocol In outcols
        ws.Range(ocol & st & ":" & ocol & en).ClearContents
    Next
End Sub
'全出力対象列へ-を出力
Private Sub set_out_cols(ws As Worksheet, ByVal mrow As Long, outcols As Variant)
    Dim ocol As Variant
    For Each ocol In outcols
        ws.Cells(mrow, ocol).Value = "-"
    Next
End Sub
Private Sub error(ws As Worksheet, ByVal rowNo As Long, ByVal msg As String)
    ws.Cells(rowNo, BubanCol).Select
    MsgBox (msg)
    End
End Sub
 

T3B0aW9uIEV4cGxpY2l0CkNvbnN0IFN0YXJ0Um93IEFzIExvbmcgPSA2ICAgICAgICAgICfjg4fjg7zjgr/plovlp4vooYwoMeS7peS4iuOCkuaMh+WumikKQ29uc3QgQnViYW5Db2wgQXMgU3RyaW5nID0gIkUiICAgICAgJ+mDqOeVquWIlwpDb25zdCBPdXRDb2xUYmwgQXMgU3RyaW5nID0gIkwsTyxSLFUsWCxBQSxBRCxBRyxBSixBTSxBUCxBUyxBVixBWSxCQixCRSIgICAgICAgJy3lh7rlipvlr77osaHliJcKUHVibGljIFN1YiDntI3lk4Hlr77osaHlpJbpg6jlk4EoKQogICAgRGltIGJpYXMgQXMgTG9uZwogICAgRGltIHdzIEFzIFdvcmtzaGVldAogICAgRGltIGxhc3RSb3cgQXMgTG9uZwogICAgRGltIHdyb3cgQXMgTG9uZwogICAgRGltIG5vX2JsayBBcyBMb25nCiAgICBEaW0gc3RyIEFzIFN0cmluZwogICAgRGltIGJubyBBcyBMb25nCiAgICBEaW0gaW5vIEFzIExvbmcKICAgIERpbSBvdXRjb2xzIEFzIFZhcmlhbnQKICAgIG91dGNvbHMgPSBTcGxpdChPdXRDb2xUYmwsICIsIikKICAgIGJpYXMgPSBTdGFydFJvdyAtIDEKICAgIFNldCB3cyA9IEFjdGl2ZVNoZWV0CiAgICBsYXN0Um93ID0gd3MuQ2VsbHMoUm93cy5Db3VudCwgQnViYW5Db2wpLkVuZCh4bFVwKS5yb3cKICAgIElmIGxhc3RSb3cgPCAoYmlhcyArIDMpIE9yIChsYXN0Um93IC0gYmlhcykgTW9kIDMgPD4gMCBUaGVuCiAgICAgICAgQ2FsbCBlcnJvcih3cywgbGFzdFJvdywgIuacgOe1guihjOS4jeatoyIpCiAgICBFbmQgSWYKICAgIG5vX2JsayA9IChsYXN0Um93IC0gYmlhcykgXCAzCiAgICBDYWxsIGNsZWFyX291dF9jb2xzKHdzLCBTdGFydFJvdywgbGFzdFJvdywgb3V0Y29scykgICAn5YWo44Gm44Gu5Ye65Yqb5a++6LGh5YiX44KS44Kv44Oq44KiCiAgICBGb3IgYm5vID0gMSBUbyBub19ibGsKICAgICAgICBEaW0gcm93QSBBcyBMb25nOiByb3dBID0gMAogICAgICAgIERpbSByb3dCIEFzIExvbmc6IHJvd0IgPSAwCiAgICAgICAgRGltIHJvd0ggQXMgTG9uZzogcm93SCA9IDAKICAgICAgICBEaW0gcm93X21hcmsgQXMgTG9uZzogcm93X21hcmsgPSAwCiAgICAgICAgRGltIHB2X3dkIEFzIFN0cmluZzogcHZfd2QgPSAiIgogICAgICAgIERpbSBlbl93ZCBBcyBTdHJpbmcKICAgICAgICBGb3IgaW5vID0gMSBUbyAzCiAgICAgICAgICAgIHdyb3cgPSBiaWFzICsgKGJubyAtIDEpICogMyArIGlubwogICAgICAgICAgICBzdHIgPSB3cy5DZWxscyh3cm93LCBCdWJhbkNvbCkuVmFsdWUKICAgICAgICAgICAgRGltIHdkIEFzIFN0cmluZwogICAgICAgICAgICBTZWxlY3QgQ2FzZSBSaWdodChzdHIsIDEpCiAgICAgICAgICAgIENhc2UgIkEiCiAgICAgICAgICAgICAgICBJZiByb3dBIDw+IDAgVGhlbiBDYWxsIGVycm9yKHdzLCB3cm93LCAi57WC56uv5paH5a2XQeOBjDLlm57lh7rnj74iKQogICAgICAgICAgICAgICAgcm93QSA9IHdyb3cKICAgICAgICAgICAgICAgIHdkID0gTGVmdChzdHIsIExlbihzdHIpIC0gMSkKICAgICAgICAgICAgQ2FzZSAiQiIKICAgICAgICAgICAgICAgIElmIHJvd0IgPD4gMCBUaGVuIENhbGwgZXJyb3Iod3MsIHdyb3csICLntYLnq6/mloflrZdC44GMMuWbnuWHuuePviIpCiAgICAgICAgICAgICAgICByb3dCID0gd3JvdwogICAgICAgICAgICAgICAgd2QgPSBMZWZ0KHN0ciwgTGVuKHN0cikgLSAxKQogICAgICAgICAgICBDYXNlICJIIgogICAgICAgICAgICAgICAgSWYgcm93SCA8PiAwIFRoZW4gQ2FsbCBlcnJvcih3cywgd3JvdywgIue1guerr+aWh+Wtl0jjgYwy5Zue5Ye654++IikKICAgICAgICAgICAgICAgIHJvd0ggPSB3cm93CiAgICAgICAgICAgICAgICBlbl93ZCA9IFJpZ2h0KHN0ciwgMikKICAgICAgICAgICAgICAgIFNlbGVjdCBDYXNlIGVuX3dkCiAgICAgICAgICAgICAgICBDYXNlICJBSCIKICAgICAgICAgICAgICAgIENhc2UgIkJIIgogICAgICAgICAgICAgICAgQ2FzZSBFbHNlCiAgICAgICAgICAgICAgICAgICAgQ2FsbCBlcnJvcih3cywgd3JvdywgIue1guerr+aWh+Wtl+OBjEFILEJI44Gu5L2V44KM44GL44Gn44Gq44GEIikKICAgICAgICAgICAgICAgIEVuZCBTZWxlY3QKICAgICAgICAgICAgICAgIHdkID0gTGVmdChzdHIsIExlbihzdHIpIC0gMikKICAgICAgICAgICAgQ2FzZSBFbHNlCiAgICAgICAgICAgICAgICBDYWxsIGVycm9yKHdzLCB3cm93LCAi57WC56uv5paH5a2X44GMQSxCLEjjga7kvZXjgozjgYvjgafjgarjgYQiKQogICAgICAgICAgICBFbmQgU2VsZWN0CiAgICAgICAgICAgIElmIExlbih3ZCkgPSAwIFRoZW4gQ2FsbCBlcnJvcih3cywgd3JvdywgIumDqOeVquOBruWFsemAmuaWh+Wtl+OBjOepuiIpCiAgICAgICAgICAgIElmIHB2X3dkID0gIiIgVGhlbgogICAgICAgICAgICAgICAgcHZfd2QgPSB3ZAogICAgICAgICAgICBFbHNlCiAgICAgICAgICAgICAgICBJZiBwdl93ZCA8PiB3ZCBUaGVuIENhbGwgZXJyb3Iod3MsIHdyb3csICLpg6jnlarjga7lhbHpgJrmloflrZfjgYzkuI3kuIDoh7QiKQogICAgICAgICAgICBFbmQgSWYKICAgICAgICBOZXh0CiAgICAgICAgSWYgZW5fd2QgPSAiQUgiIFRoZW4gcm93X21hcmsgPSByb3dBCiAgICAgICAgSWYgZW5fd2QgPSAiQkgiIFRoZW4gcm93X21hcmsgPSByb3dCCiAgICAgICAgSWYgcm93X21hcmsgPSAwIFRoZW4gQ2FsbCBlcnJvcih3cywgd3JvdywgIue0jeWTgeWvvuixoeWkluihjOOBjOaxuuWumuOBp+OBjeOBquOBhCIpCiAgICAgICAgQ2FsbCBzZXRfb3V0X2NvbHMod3MsIHJvd19tYXJrLCBvdXRjb2xzKSAgICAn5YWo44Gm44Gu5Ye65Yqb5a++6LGh5YiX44G4LeioreWumgogICAgTmV4dAogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1Ygon5YWo5Ye65Yqb5a++6LGh5YiX44KS44Kv44Oq44KiClByaXZhdGUgU3ViIGNsZWFyX291dF9jb2xzKHdzIEFzIFdvcmtzaGVldCwgQnlWYWwgc3QgQXMgTG9uZywgQnlWYWwgZW4gQXMgTG9uZywgb3V0Y29scyBBcyBWYXJpYW50KQogICAgRGltIG9jb2wgQXMgVmFyaWFudAogICAgRm9yIEVhY2ggb2NvbCBJbiBvdXRjb2xzCiAgICAgICAgd3MuUmFuZ2Uob2NvbCAmIHN0ICYgIjoiICYgb2NvbCAmIGVuKS5DbGVhckNvbnRlbnRzCiAgICBOZXh0CkVuZCBTdWIKJ+WFqOWHuuWKm+WvvuixoeWIl+OBuC3jgpLlh7rlipsKUHJpdmF0ZSBTdWIgc2V0X291dF9jb2xzKHdzIEFzIFdvcmtzaGVldCwgQnlWYWwgbXJvdyBBcyBMb25nLCBvdXRjb2xzIEFzIFZhcmlhbnQpCiAgICBEaW0gb2NvbCBBcyBWYXJpYW50CiAgICBGb3IgRWFjaCBvY29sIEluIG91dGNvbHMKICAgICAgICB3cy5DZWxscyhtcm93LCBvY29sKS5WYWx1ZSA9ICItIgogICAgTmV4dApFbmQgU3ViClByaXZhdGUgU3ViIGVycm9yKHdzIEFzIFdvcmtzaGVldCwgQnlWYWwgcm93Tm8gQXMgTG9uZywgQnlWYWwgbXNnIEFzIFN0cmluZykKICAgIHdzLkNlbGxzKHJvd05vLCBCdWJhbkNvbCkuU2VsZWN0CiAgICBNc2dCb3ggKG1zZykKICAgIEVuZApFbmQgU3ViCg==