空白行を削除せずに詰める方法を教えてください。

Question

前提・実現したいこと

別のブックからシートをコピーし、貼り付けをした後に、L列にある空白のセル以外を削除してから、さらに空白を詰めたいのですが、ご教授いただければ幸いです。

発生している問題・エラーメッセージ

L列にある空白のセル以外を削除してみたら、空白のセルも消えてしまう。
空白を詰めてみたら、文字が下に下に上書きされてしまう。

エラーメッセージ

該当のソースコード

Dim sh As Worksheet
Dim rE As Long
Dim i As Long
Dim toprow As Long
Dim bottomrow As Long
Dim k As Integer
Dim j As Integer

Sub main()

tyusyutu
CommandButton1_Click
Tumeru
End Sub

Sub tyusyutu()

'データのコピー
    Set wb = Workbooks.Open("C:\Book1.xlsx")
    Set sh = wb.Sheets(2)
    rE = sh.Cells(Rows.Count, "B").End(xlUp).Row
    Range(Cells(5, "B"), Cells(rE, "L")).Copy
    wb.Close
    Cells(5, "B").PasteSpecial
End Sub

Private Sub CommandButton1_Click()
'''''''''''''''''''''''''''''''''''''''''''''''''''    
    '開始する行
    toprow = 5
    '終了する行
    bottomrow = 74
    
    For i = bottomrow To toprow Step -1
        If ActiveSheet.Cells(i, 12) <> "" Then
            Range("B5:L74").Rows(i).ClearContents
        End If
    Next
'''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub

Sub Tumeru()
'''''''''''''''''''''''''''''''''''''''''''''''''''
j = 5
For k = 5 To Range("B" & Rows.Count).End(xlUp).Row
If (Range("B" & k).Rows <> "") Then
j = j + 1
Range("B" & k).Resize(, 11).Copy Range("B" & j)
Range("B" & k).Resize(, 11) = ""
End If
Next k
'''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub

コード

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

ほかのbookから貼り付けます。

L列の文字が入っているセルを削除しようとします。

真っ白になる。

下にスクロースすると、一番上の貼り付けたセルが、一番下に降りてしまう。

と、こんな感じになってしまいます。
わかりにくいかもしれませんが、よろしくお願いします。

Comments

[radames1000]

コードが見づらいので```でコードを囲んでください。
また、具体例（今の表⇒こんな形にしたい）をそれぞれ画像等であげてください。

[meg_]

コードは「コードの挿入｣で記入してください。

[matuo7538]

修正しましたので、よろしくお願いします。

Answer 1

とりあえず、
Range("B5:L74").Rows(i).ClearContents のところは、
ActiveSheet.Rows(i).ClearContents ではないかと思います。

Comments

[matuo7538]

ご回答ありがとうございます。
ActiveSheetに変えると、行ごとクリアされてしまいました。
そもそもrowsを使うこと自体間違いなのでしょうか？

[jinoji]

あ、失礼しました。
ActiveSheet.Columns("B:L").Rows(i).ClearContents ならどうでしょう。

[jinoji]

Range("B5:L74").Rows(i)　だと、iが５の時は9行目（"B5:L74"の中の5行目）が処理されるはず。

[jinoji]

そもそも、こんな感じではいけないのでしょうか。

Dim O As Worksheet, P As Worksheet
Set O = Sheets("O")
Set P = Sheets("P")
Dim i, j
j = 5
For i = 5 To P.Cells(Rows.Count, "B").End(xlUp).Row
If P.Cells(i, "L") = "" Then
P.Cells(i, "B").Resize(, 11).Copy O.Cells(j, "B")
j = j + 1
End If
Next

[matuo7538]

ありがとうございます。
教えていただいたおかげで、文字の入ったものを消すことができました。

あと、ややこしくしてしまい申し訳ございません。
Oのシート、質問とまったく関係ありません。
もし、私が的外れなことを言っていたら、申し訳ございません。

[jinoji]

こちらこそ失礼しました。別のブックから、と書いてあるのを見落としていました。

ただ、言いたかったのは、コピーしてからクリアして詰める、じゃなくて、
最初から必要な行を選びながらコピーする手もあるのでは、ということです。

Sub tyusyutuAndTumeru()

'データのコピー
Set outSheet = Activesheet
Set wb = Workbooks.Open("C:\Book1.xlsx")
Set sh = wb.Sheets(2)
rE = sh.Cells(Rows.Count, "B").End(xlUp).Row
Dim i, j
j = 5
For i = 5 To rE
If sh.Cells(i, "L") = "" Then
sh.Cells(i, "B").Resize(, 11).Copy outSheet.Cells(j, "B")
j = j + 1
End If
Next
wb.Close
End Sub

[matuo7538]

思った通りにできました！
ありがとうございました。

Answer 2

おそらく一番の原因はTumeruの方ですね。

現在のコードを実行すると、

・5行目→6行目にコピーし、5行目を削除
・6行目→7行目にコピーし、6行目を削除

といった具合に繰り返されてしまい、結果として途中のデータはすべて消去され、最終行に5行目のデータが残るのみ、という挙動をしています。
このあたりの不具合は、F8によるステップ実行などを使えるようになると、容易に発見できるようになると思います。

肝心の解決策については色々なやり方がありますが、まずは素直に逆順ループをして、空白行を削除していくのが良いと思います。

Sub Tumeru()

For k = Range("B" & Rows.Count).End(xlUp).Row To 5 Step -1
    If (Range("B" & k) = "") Then
            
        Range("B:L").Rows(k).Delete Shift:=xlUp
    
    End If
Next k

End Sub

【追記】
上記のコードは単純ですが、件数が多い場合はとんでもなく遅くなります。
そうした遅さに耐えられなくなった場合は、例えば以下のようにDelete処理を一回にまとめるとはやいです。

Sub Tumeru()

Dim Target As Range
For k = 5 To Range("B" & Rows.Count).End(xlUp).Row
    If (Range("B" & k) = "") Then
        
        If Target Is Nothing Then
            
            Set Target = Range("B:L").Rows(k)
        
        Else
            
            Set Target = Union(Target, Range("B:L").Rows(k))
        
        End If
        
    End If
Next k

Target.Delete shift:=xlUp

End Sub

Comments

[matuo7538]

ありがとうございます。
書式を消さずに空白を詰めたいので、教えていただいたコードのDeleteを、ClearContentsに変えればできるかと思って実行したところ、「アプリケーション定義またはオブジェクト定義エラーです」と出てしまいました。
説明が足りなく申し訳ございません。
よろしければ、ご教授願います。

[Usirow]

私の書いたコードの場合「空白行をDeleteして、削除された分を上方向に詰める」というつくりなので、そもそもClearContentsしても何も起きないと思います。
そしてClearContentsでそのエラーが出るのは、申し訳ないですがよくわかりません。考えられることは「shift:= xlUp」をそのままにしてしまっている、くらいでしょうか。