Option Explicit
 
Const Folder As String = "d:\goo\data2"
Const BookName As String = "Book1.xlsx"
Const SheetName As String = "Sheet1"
Const MarginRow As Long = 3  '製品名開始直前迄の行
Public Sub 日付数量抽出()
    Dim wb As Workbook      '入力ブック
    Dim ws As Worksheet     '入力ブックの入力シート
    Dim ws2 As Worksheet    '出力シート
    Dim maxrow As Long      '入力シート最大行数
    Dim maxrow2 As Long     '出力シート最大行数
    Dim pcount As Long      '製品件数
    Dim wrow As Long        '入力シート行番号
    Dim wcol As Long        '入力シート列番号
    Dim wrow2 As Long       '出力シート行番号
    Dim wcol2 As Long       '出力シート列番号
    Dim i As Long           '製品番号
    Dim ctr As Long         '登録数量カウンタ
    Dim pname As String     '製品名
    Dim comment As String   'コメント（W列）
    Set ws2 = Worksheets("Sheet2")
    '入力ファイルオープン
    Set wb = Workbooks.Open(Folder & "\" & BookName)
    Set ws = wb.Worksheets(SheetName)
    maxrow = ws.Cells(Rows.Count, "G").End(xlUp).Row    'G列の最大行取得
    '11行未満の場合
    If maxrow < MarginRow + 8 Then
        MsgBox ("製品名なし")
        Exit Sub
    End If
    '製品件数算出
    pcount = (maxrow - MarginRow) \ 8
    If (maxrow - MarginRow) Mod 8 <> 0 Then
        MsgBox ("終端行不正")
        Exit Sub
    End If
    '出力シートクリア
    maxrow2 = ws2.Cells(Rows.Count, "D").End(xlUp).Row    'D列の最大行取得
    If maxrow2 > 2 Then
        ws2.Range("D3:D" & maxrow2).ClearContents
        ws2.Range("AD3:AG" & maxrow2).ClearContents
    End If
    wrow2 = 3
    '製品件数分繰り返す
    For i = 1 To pcount
        '数量記入行を決定
        wrow = (i - 1) * 8 + MarginRow + 5
        pname = ws.Cells(wrow, "G").Value
        comment = ws.Cells(wrow, "W").Value
        'W列にExpiryがない場合はエラー
        If InStr(1, comment, "Expiry", 1) = 0 Then
            MsgBox (wrow & "行 W列 Expiryなし")
            Exit Sub
        End If
        ws2.Cells(wrow2, "D").Value = pname             '製品名
        ctr = 0
        'Y列～BT列まで繰り返す
        For wcol = 25 To 72
            '数量が登録されていれば、Sheet2へ転記
            If ws.Cells(wrow, wcol) <> "" Then
                wcol2 = 30 + ctr * 2
                ws2.Cells(wrow2, wcol2).Value = ws.Cells(3, wcol).Value         '日付
                ws2.Cells(wrow2, wcol2 + 1).Value = ws.Cells(wrow, wcol).Value  '数量
                ctr = ctr + 1
            End If
        Next
        '数量が１件も登録されていない場合
        If ctr = 0 Then
            ws2.Cells(wrow2, "AD").Resize(, 4).Value = "-"
        End If
        wrow2 = wrow2 + 1
    Next
    wb.Close
    MsgBox ("完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpDb25zdCBGb2xkZXIgQXMgU3RyaW5nID0gImQ6XGdvb1xkYXRhMiIKQ29uc3QgQm9va05hbWUgQXMgU3RyaW5nID0gIkJvb2sxLnhsc3giCkNvbnN0IFNoZWV0TmFtZSBBcyBTdHJpbmcgPSAiU2hlZXQxIgpDb25zdCBNYXJnaW5Sb3cgQXMgTG9uZyA9IDMgICfoo73lk4HlkI3plovlp4vnm7TliY3ov4Tjga7ooYwKUHVibGljIFN1YiDml6Xku5jmlbDph4/mir3lh7ooKQogICAgRGltIHdiIEFzIFdvcmtib29rICAgICAgJ+WFpeWKm+ODluODg+OCrwogICAgRGltIHdzIEFzIFdvcmtzaGVldCAgICAgJ+WFpeWKm+ODluODg+OCr+OBruWFpeWKm+OCt+ODvOODiAogICAgRGltIHdzMiBBcyBXb3Jrc2hlZXQgICAgJ+WHuuWKm+OCt+ODvOODiAogICAgRGltIG1heHJvdyBBcyBMb25nICAgICAgJ+WFpeWKm+OCt+ODvOODiOacgOWkp+ihjOaVsAogICAgRGltIG1heHJvdzIgQXMgTG9uZyAgICAgJ+WHuuWKm+OCt+ODvOODiOacgOWkp+ihjOaVsAogICAgRGltIHBjb3VudCBBcyBMb25nICAgICAgJ+ijveWTgeS7tuaVsAogICAgRGltIHdyb3cgQXMgTG9uZyAgICAgICAgJ+WFpeWKm+OCt+ODvOODiOihjOeVquWPtwogICAgRGltIHdjb2wgQXMgTG9uZyAgICAgICAgJ+WFpeWKm+OCt+ODvOODiOWIl+eVquWPtwogICAgRGltIHdyb3cyIEFzIExvbmcgICAgICAgJ+WHuuWKm+OCt+ODvOODiOihjOeVquWPtwogICAgRGltIHdjb2wyIEFzIExvbmcgICAgICAgJ+WHuuWKm+OCt+ODvOODiOWIl+eVquWPtwogICAgRGltIGkgQXMgTG9uZyAgICAgICAgICAgJ+ijveWTgeeVquWPtwogICAgRGltIGN0ciBBcyBMb25nICAgICAgICAgJ+eZu+mMsuaVsOmHj+OCq+OCpuODs+OCvwogICAgRGltIHBuYW1lIEFzIFN0cmluZyAgICAgJ+ijveWTgeWQjQogICAgRGltIGNvbW1lbnQgQXMgU3RyaW5nICAgJ+OCs+ODoeODs+ODiO+8iFfliJfvvIkKICAgIFNldCB3czIgPSBXb3Jrc2hlZXRzKCJTaGVldDIiKQogICAgJ+WFpeWKm+ODleOCoeOCpOODq+OCquODvOODl+ODswogICAgU2V0IHdiID0gV29ya2Jvb2tzLk9wZW4oRm9sZGVyICYgIlwiICYgQm9va05hbWUpCiAgICBTZXQgd3MgPSB3Yi5Xb3Jrc2hlZXRzKFNoZWV0TmFtZSkKICAgIG1heHJvdyA9IHdzLkNlbGxzKFJvd3MuQ291bnQsICJHIikuRW5kKHhsVXApLlJvdyAgICAnR+WIl+OBruacgOWkp+ihjOWPluW+lwogICAgJzEx6KGM5pyq5rqA44Gu5aC05ZCICiAgICBJZiBtYXhyb3cgPCBNYXJnaW5Sb3cgKyA4IFRoZW4KICAgICAgICBNc2dCb3ggKCLoo73lk4HlkI3jgarjgZciKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgICfoo73lk4Hku7bmlbDnrpflh7oKICAgIHBjb3VudCA9IChtYXhyb3cgLSBNYXJnaW5Sb3cpIFwgOAogICAgSWYgKG1heHJvdyAtIE1hcmdpblJvdykgTW9kIDggPD4gMCBUaGVuCiAgICAgICAgTXNnQm94ICgi57WC56uv6KGM5LiN5q2jIikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICAn5Ye65Yqb44K344O844OI44Kv44Oq44KiCiAgICBtYXhyb3cyID0gd3MyLkNlbGxzKFJvd3MuQ291bnQsICJEIikuRW5kKHhsVXApLlJvdyAgICAnROWIl+OBruacgOWkp+ihjOWPluW+lwogICAgSWYgbWF4cm93MiA+IDIgVGhlbgogICAgICAgIHdzMi5SYW5nZSgiRDM6RCIgJiBtYXhyb3cyKS5DbGVhckNvbnRlbnRzCiAgICAgICAgd3MyLlJhbmdlKCJBRDM6QUciICYgbWF4cm93MikuQ2xlYXJDb250ZW50cwogICAgRW5kIElmCiAgICB3cm93MiA9IDMKICAgICfoo73lk4Hku7bmlbDliIbnubDjgorov5TjgZkKICAgIEZvciBpID0gMSBUbyBwY291bnQKICAgICAgICAn5pWw6YeP6KiY5YWl6KGM44KS5rG65a6aCiAgICAgICAgd3JvdyA9IChpIC0gMSkgKiA4ICsgTWFyZ2luUm93ICsgNQogICAgICAgIHBuYW1lID0gd3MuQ2VsbHMod3JvdywgIkciKS5WYWx1ZQogICAgICAgIGNvbW1lbnQgPSB3cy5DZWxscyh3cm93LCAiVyIpLlZhbHVlCiAgICAgICAgJ1fliJfjgatFeHBpcnnjgYzjgarjgYTloLTlkIjjga/jgqjjg6njg7wKICAgICAgICBJZiBJblN0cigxLCBjb21tZW50LCAiRXhwaXJ5IiwgMSkgPSAwIFRoZW4KICAgICAgICAgICAgTXNnQm94ICh3cm93ICYgIuihjCBX5YiXIEV4cGlyeeOBquOBlyIpCiAgICAgICAgICAgIEV4aXQgU3ViCiAgICAgICAgRW5kIElmCiAgICAgICAgd3MyLkNlbGxzKHdyb3cyLCAiRCIpLlZhbHVlID0gcG5hbWUgICAgICAgICAgICAgJ+ijveWTgeWQjQogICAgICAgIGN0ciA9IDAKICAgICAgICAnWeWIl++9nkJU5YiX44G+44Gn57mw44KK6L+U44GZCiAgICAgICAgRm9yIHdjb2wgPSAyNSBUbyA3MgogICAgICAgICAgICAn5pWw6YeP44GM55m76Yyy44GV44KM44Gm44GE44KM44Gw44CBU2hlZXQy44G46Lui6KiYCiAgICAgICAgICAgIElmIHdzLkNlbGxzKHdyb3csIHdjb2wpIDw+ICIiIFRoZW4KICAgICAgICAgICAgICAgIHdjb2wyID0gMzAgKyBjdHIgKiAyCiAgICAgICAgICAgICAgICB3czIuQ2VsbHMod3JvdzIsIHdjb2wyKS5WYWx1ZSA9IHdzLkNlbGxzKDMsIHdjb2wpLlZhbHVlICAgICAgICAgJ+aXpeS7mAogICAgICAgICAgICAgICAgd3MyLkNlbGxzKHdyb3cyLCB3Y29sMiArIDEpLlZhbHVlID0gd3MuQ2VsbHMod3Jvdywgd2NvbCkuVmFsdWUgICfmlbDph48KICAgICAgICAgICAgICAgIGN0ciA9IGN0ciArIDEKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgTmV4dAogICAgICAgICfmlbDph4/jgYzvvJHku7bjgoLnmbvpjLLjgZXjgozjgabjgYTjgarjgYTloLTlkIgKICAgICAgICBJZiBjdHIgPSAwIFRoZW4KICAgICAgICAgICAgd3MyLkNlbGxzKHdyb3cyLCAiQUQiKS5SZXNpemUoLCA0KS5WYWx1ZSA9ICItIgogICAgICAgIEVuZCBJZgogICAgICAgIHdyb3cyID0gd3JvdzIgKyAxCiAgICBOZXh0CiAgICB3Yi5DbG9zZQogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1Ygo=