Attribute VB_Name = "Module1"
'■　マクロ５００連発＜第２段＞
'
'　ワークシートのデータを整形する
'
'  Copyright(C) 2000 Sunago
'
'　Ａ列　Ｂ列　Ｃ列　　　　Ｄ列　　Ｅ列　Ｆ列　Ｇ列　　　AM列　AN列
'  納期　品種　商品コード　取引先　色1 　数1 　色2 　〜　色18　数18
'
'　　↓
'
'　Ａ列　Ｂ列　Ｃ列　　　　Ｄ列　　Ｅ列　Ｆ列
'  納期　品種　商品コード　取引先　色1   数1
'  納期　品種　商品コード　取引先　色2 　数2
'  　：
'  納期　品種　商品コード　取引先　色18　数18

Option Explicit

Sub Macro1()
Dim objTarget As Worksheet
Dim objOutput As Worksheet
Dim myArray(1 To 6) As Variant  '出力データを格納する配列
Dim r As Long                   '処理対象行位置
Dim c As Integer                '処理対象列位置
Dim maxr As Long                '処理対象最大行位置
Dim outr As Long                '出力先行位置
Dim i As Long                   '項目番号
Dim wkvalue As Variant          '一時的な格納変数

    Set objTarget = Worksheets("納品データ")
    Set objOutput = Worksheets("整形後のデータ")
    
    '出力先のデータを初期化する
    objOutput.Cells.Clear
    
    '出力先の見出しを作成する
    outr = 1
    objOutput.Cells(1, 1) = "納期"
    objOutput.Cells(1, 2) = "品種"
    objOutput.Cells(1, 3) = "商品コード"
    objOutput.Cells(1, 4) = "取引先"
    objOutput.Cells(1, 5) = "色番"
    objOutput.Cells(1, 6) = "数量"
    
    '処理対象最大行位置を調べる
    maxr = objTarget.Range("A65536").End(xlUp).Row
    
    '１行すつ正規化を行う
    For r = 2 To maxr
        '１列目が空白である行は処理しない
        If objTarget.Cells(r, 1).Value <> "" Then
            myArray(1) = objTarget.Cells(r, 1).Value     '納期
            myArray(2) = objTarget.Cells(r, 2).Value     '品種
            myArray(3) = objTarget.Cells(r, 3).Value     '商品コード
            myArray(4) = objTarget.Cells(r, 4).Value     '取引先
            For i = 1 To 18
                '項目番号から基準となる列位置を求める
                c = (i - 1) * 2 + 5
                wkvalue = objTarget.Cells(r, c + 1).Value    '数量
                If IsNumeric(wkvalue) And wkvalue <> 0 Then
                    myArray(5) = objTarget.Cells(r, c).Value '色番
                    myArray(6) = wkvalue
                    '出力先行位置を +1 する
                    outr = outr + 1
                    With objOutput
                        '日付の表示形式を設定
                        .Cells(outr, 1).NumberFormat = objTarget.Cells(2, 1).NumberFormat
                        '配列からワークシートへセットする
                        .Range(.Cells(outr, 1), .Cells(outr, 6)) = myArray()
                    End With
                End If
            Next
        End If
    Next

End Sub