空白のセルを含む一覧表を、空白セルを無視して転記したい

Question

前提

備品の在庫管理や発注管理にExcelを用いているのですが、種類が増えてきたことや、誰もが作業できるような管理表を作成したいと考えています。

実現したいこと

• 空白のセルを含む一覧表を、空白セルを無視し、空白セル以降も継続して転記したい

（空白のセルがあった際は、転記先のシートでは1行飛ばして次の行へ転記させるようにしたい。）

現在の表形式

備品の種類	保管場所	数量	発注担当者
備品A	棚番号1	100	A
	棚番号2	100	B
備品B	棚番号2	10	B
備品C	棚番号1	10	A
備品D	棚番号2	50	B
			C
備品D	棚番号2	10	B
備品E	棚番号1	10	A

以上のような表が続いております。
数が100以上必要なものに関しては、保管場所も複数個所となる為、
行を挿入して対応していくというルール付けがなされております。
※訂正
数が50以上必要なものは、発注担当者も複数名になることがある為、
こちらも行を挿入して対応していくこととなっています。

ご教示いただきたい点

他のシートへの転記は以下のコード各項目分用意して使用しようと考えております。

If Worksheets("SHEET2").Range("A2").Value = "" Then
Worksheets("SHEET2").Range("A3").Offset(1, 0).Value = Worksheets("SHHT1").Range("A2").Value
Else
Worksheets("SHEET2").Range("A3").End(xlDown).Offset(1, 0).Value = Worksheets("SHHT1").Range("A2").Value
End If

End Sub

ただし、上記のコードですと途中の行に空欄があった際に、無視して進めることができません。
空欄にはスペースを入力することで対応できるかとは思いますが、空欄を無視して次の行から継続して転記をさせることは可能でしょうか？
また、1つのセルの内容を転記させるのではなく、転記元のセルも下へと移動していく場合は、どのようにすれば解決しますでしょうか？

様々なサイトを閲覧しましたが、空白セルを含む一覧表の転記について自力で見つけることができず不甲斐ないばかりですが、参考となるサイト等がございましたら併せてご教示いただけますと嬉しく思います。

宜しくお願い致します。

※追記
pig_vba様　こちらこそ状況の説明が上手くできておらず、大変申し訳ございません。

転記元

備品の種類	保管場所	数量	発注担当者
備品A	棚番号1	100	A
	棚番号2	100	B
備品B	棚番号2	10	B
備品C	棚番号1	10	A
備品D	棚番号2	50	B
			C
備品E	棚番号1	10	A

転記先

備品の種類
保管場所	数量
発注担当者

上記のような形にしたく、最終的には以下のような配列になるようにしたいです。

備品A
棚番号1	100
棚番号2	100
A
B
備品B
棚番号2	10
B
備品C
棚番号1	10
A
備品D
棚番号1	10
B
C
備品E
棚番号2	10
A

大変わかりにくい表で申し訳ございませんが、こちらで大丈夫でしょうか…？

Comments

[pig_vba]

すみません。私の理解不足ではありますが説明内に若干の矛盾がみられるため、目指すべき形が想像できません。
数行のサンプルで構わないので転記元と転記先の表をセットで提示していただけませんか？

[shibakoppe]

閲覧いただき、誠にありがとうございます。
また質問の内容がわかりにくい上に、状況をしっかりと伝えられなかったこと、返信が遅くなってしまったこと、深くお詫び申し上げます。。
質問文に追記という形で掲載させていただきましたが、こちらでよろしいでしょうか…？
管理の仕方に独特なルール付けがなされており、一見不便そうな取り扱いに見えてしまうのですが、上記のような配列で作成したく思います。
お手数をおかけしますが、よろしければお力添えを賜りたく思います。
何卒、宜しくお願い申し上げます。

[pig_vba]

ありがとうございます。おかげさまで仕様が理解できました。
ふむ…実装自体は可能だと思いますが、少し面倒なコードになりそうですね…
追加確認ですが、空欄は２行以上連続する可能性はありますか？

[shibakoppe]

ご確認いただき、誠にありがとうございます。
そうなんですね…
ご面倒をおかけし申し訳ございません…。
空欄についてですが、発注先の関係で発注者が2名以上になる場合もあるので、2行以上連続する可能性は高いです。

[pig_vba]

了解しました。ならば処理の順序としては
①次が空白かで分岐(一行だけか否か)
②空白行数を数える(処理→保管場所→発注者の順番で格納する必要があるため)
③行数分転記処理
④次の備品種類の行までoffsetで移動
って流れになりそうですね。

[shibakoppe]

なるほど…。
順序立てまでしていただきありがとうございます。
ご面倒をおかけしてしまい申し訳ございませんが、よろしければ詳しくご教示いただくことは可能でしょうか…？

[pig_vba]

書いてみたらネスト深すぎてクッソ面倒なフローになったので関数分けしました。それに伴い処理の流れを提示時点と変更していますのでご注意ください

Answer 1

・データ四列である前提です。VBAコード自体は読めるでしょうから必要な修正個所はコメント参照しながらご自身で行ってください(さすがにそこまで対応するとただの作業依頼なので)
・以後も改修される可能性の高さから配列での高速化等の最適化は行っておりません。処理の単純さを優先しました。機能性向上を目指すならロジックの参考程度にしてください

Option Explicit

Sub 棚卸転記()
    
    
    Dim wsForm As Worksheet '転記元シート
    Dim wsPost As Worksheet '転記先シート
    
    'ここは自分で書き換えてください----------------------------------------------
    Set wsForm = ThisWorkbook.Sheets("Sheet2")
    Set wsPost = ThisWorkbook.Sheets("Sheet3")
    
    Const START_ROW As Long = 2 'データ開始行(タイトル除く)
    Const DATA_COLUMN As Long = 1 'データは何行目にあるか(今回は例としてA列)
    
    '----------------------------------------------------------------------------
    'そのほかの項目
    Dim end_row As Long 'データ最終行
    end_row = wsForm.Cells(Rows.Count, DATA_COLUMN + 3).End(xlUp).row '最終行取得(空白を加味して発注担当者行を基準に設定)※数値不定の為const使用不可
    
    Dim blankCnt As Long '空白行数計算用
    Dim rowCnt As Long
    Dim colCnt As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For rowCnt = START_ROW To end_row
        blankCnt = 0
        
        '空白行数カウント
        Do While (wsForm.Cells(rowCnt + blankCnt + 1, DATA_COLUMN).Value = "") '次の行が空白じゃなくなるまでループ
            '最終行に達してたら終了
            If rowCnt + blankCnt >= end_row Then Exit Do
            
            blankCnt = blankCnt + 1
        Loop
        
        Call データ転記(wsForm, wsPost, wsForm.Cells(rowCnt, DATA_COLUMN), blankCnt)
        
        '邪道ではあるが、空白行数分ループを進める(処理済みなので)
        rowCnt = rowCnt + blankCnt
    Next rowCnt
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Private Sub データ転記(form As Worksheet, post As Worksheet, rngData As Range, ByVal cnt As Long)
    'データ転記関数
    'form   :転記元シート
    'post   :転記先シート
    'rngData:転記するデータの先頭セル
    'cnt    :空白行数(forが0スタートなので処理行数-1であることに注意)
    
    Dim rng As Range
    Dim i As Long
    Dim col As Long
    '転記先のA列に転記していく場合
    '最後尾セル取得
    Set rng = post.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    
    
    '行→列の順番でループ(項目”数量”のみ処理を変更する)----------------------------------------------------------------
    For col = 0 To 3
        
        '3列目なら転記位置が違うので処理を変える(基本部分は同じ)
        If col = 2 Then
            Set rng = rng.Offset(-(cnt + 1), 0) '行数を保管場所の行数分戻す
            For i = 0 To cnt
                If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了
                
                rng.Offset(0, 1).Value = rngData.Offset(i, col).Value
                Set rng = rng.Offset(1, 0) '一列下に移動
            Next i
        Else
            For i = 0 To cnt
                If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了
                
                rng.Value = rngData.Offset(i, col).Value
                Set rng = rng.Offset(1, 0) '一列下に移動
            Next i
        End If
    Next col
    
    '処理終わり----------------------------------
    Set rng = Nothing
    
    
End Sub

Comments

[shibakoppe]

とても細かく提示してくださって誠にありがとうございました！
知識が乏しい私でも、とても分かりやすかったです！
本当に助かりました◎
ご丁寧に対応していただけて、本当に嬉しかったです。
改めて、この度は大変お世話になりました！