空白を埋めるマクロについて

質問

マクロで教えて下さい！

A B C D 　　　......
数量　名前　種類 購入者 　....
1 　2　　あ　　A
2　　　　く
3 5 DD
4　　　　　　　　　　まま
5　　　　さ
6　　　　　　　　　　ぱぱ

と右は何十項目・下は何千行と項目が続くデータがあります。
この空白に上の文字をコピーし埋めて行くマクロを作成するにはどうしたら良いでしょうか？
ただし以下の条件があります。

(1)D列の様に1行目が空白のセルは4行目の様に文字が入っている所までは空白のまま
(2)A列はそのファイルにより何行目までデータが入っているかは不明

A B C D 　　　
数量　名前　種類 購入者 　
1 　2　　あ　　A 　　　　　
2　 2　　く A
3 5 く DD
4　 5　　く DD 　　まま
5　 5　　さ DD まま
6　 5　　さ DD　 　ぱぱ

宜しくお願い致します。

回答No.5

Wendy02

こんにちは。
Wendy02です。

＞メモリの調べ方が分からないのですが、恐らく512はあったと思います。
Excelの場合は、物理メモリは関係ありませんが、

＞2000行弱、60列弱に空白以外は文字がびっしり書かれています。

これを知っていたら、そのようには作りませんでしたが、各列で範囲を取っているので、2000行で、メモリ枠でエラーが出る可能性は低いです。私の知っている限りですと、配列でエラーになるのは、エラー値が混入していることがありますね。たぶん、Copy ですと、エラー値もコピーできるような気がします。

一応、第2段のコードも用意はしていますが、一度、以下を試してみてください。

'----------------------------------------------------------

Sub BlankCellsEntering2()
　 Dim r As Range
　 Dim rb As Range
　 Dim cl As Range
　 Dim a As Variant
　 Dim MaxRow As Long
　 Dim c As Range
　 Application.ScreenUpdating = False

　 '最初の基点場所
　 '範囲の取得
　 For Each c In Range("A1:D1")
　　　If Cells(65536, c.Column).End(xlUp).Row > MaxRow Then
　　　　 MaxRow = Cells(65536, c.Column).End(xlUp).Row
　　　End If
　 Next
　 Set r = Range("A1").Resize(MaxRow, 4)

　 Application.ScreenUpdating = False
　 '縦切りで取る
　 For Each cl In r.Columns

　　　On Error Resume Next
　　　Set rb = cl.SpecialCells(xlCellTypeBlanks)
　　　On Error GoTo 0
　　　If Not rb Is Nothing Then
　　　　 For Each a In rb.Areas 'Areas で取る
　　　　　　With a
　　　　　　　 If .Row > r.Cells(2, 1).Row Then
　　　　　　　　 .Cells(1, 1).Offset(-1).Copy .Cells
　　　　　　　 End If
　　　　　　End With
　　　　 Next a
　　　End If
　 Next cl
　 Application.ScreenUpdating = True
　 Set rb = Nothing:　 Set r = Nothing
End Sub

お礼

早速のお返事ありがとうございます！お忙しい中私なんかの為に本当にありがとうございます。涙

データ量により、マクロが変わるんですか？知りませんでした。。言葉足らずで申し訳ございません。

頂いたもので試した所、凄いスピードでA～D列まで空白が埋まりました！

今まで出ていたエラーのマクロで、行数を大幅に減らして試したところ、そのデータファイルにもよるんですが、大体200～500行までですと正常に軌道してくれました。