Q&A
コードが見づらいので```でコードを囲んでください。
また、具体例（今の表⇒こんな形にしたい）をそれぞれ画像等であげてください。
前提・実現したいこと
別のブックからシートをコピーし、貼り付けをした後に、L列にある空白のセル以外を削除してから、さらに空白を詰めたいのですが、ご教授いただければ幸いです。
発生している問題・エラーメッセージ
L列にある空白のセル以外を削除してみたら、空白のセルも消えてしまう。
空白を詰めてみたら、文字が下に下に上書きされてしまう。
エラーメッセージ
該当のソースコード
Dim
1Dim sh As Worksheet 2Dim rE As Long 3Dim i As Long 4Dim toprow As Long 5Dim bottomrow As Long 6Dim k As Integer 7Dim j As Integer 8 9Sub main() 10 11tyusyutu 12CommandButton1_Click 13Tumeru 14End Sub 15 16Sub tyusyutu() 17 18'データのコピー 19 Set wb = Workbooks.Open("C:\Book1.xlsx") 20 Set sh = wb.Sheets(2) 21 rE = sh.Cells(Rows.Count, "B").End(xlUp).Row 22 Range(Cells(5, "B"), Cells(rE, "L")).Copy 23 wb.Close 24 Cells(5, "B").PasteSpecial 25End Sub 26 27Private Sub CommandButton1_Click() 28''''''''''''''''''''''''''''''''''''''''''''''''''' 29 '開始する行 30 toprow = 5 31 '終了する行 32 bottomrow = 74 33 34 For i = bottomrow To toprow Step -1 35 If ActiveSheet.Cells(i, 12) <> "" Then 36 Range("B5:L74").Rows(i).ClearContents 37 End If 38 Next 39''''''''''''''''''''''''''''''''''''''''''''''''''' 40End Sub 41 42Sub Tumeru() 43''''''''''''''''''''''''''''''''''''''''''''''''''' 44j = 5 45For k = 5 To Range("B" & Rows.Count).End(xlUp).Row 46If (Range("B" & k).Rows <> "") Then 47j = j + 1 48Range("B" & k).Resize(, 11).Copy Range("B" & j) 49Range("B" & k).Resize(, 11) = "" 50End If 51Next k 52''''''''''''''''''''''''''''''''''''''''''''''''''' 53End Sub 54 55コード
試したこと
ここに問題に対して試したことを記載してください。
補足情報（FW/ツールのバージョンなど）
ほかのbookから貼り付けます。
L列の文字が入っているセルを削除しようとします。
真っ白になる。
下にスクロースすると、一番上の貼り付けたセルが、一番下に降りてしまう。
と、こんな感じになってしまいます。
わかりにくいかもしれませんが、よろしくお願いします。
回答2件
0
ベストアンサー
とりあえず、
Range("B5:L74").Rows(i).ClearContents のところは、
ActiveSheet.Rows(i).ClearContents ではないかと思います。
投稿2021/02/20 01:38
総合スコア4592
ご回答ありがとうございます。
ActiveSheetに変えると、行ごとクリアされてしまいました。
そもそもrowsを使うこと自体間違いなのでしょうか？
あ、失礼しました。
ActiveSheet.Columns("B:L").Rows(i).ClearContents ならどうでしょう。
Range("B5:L74").Rows(i) だと、iが５の時は9行目（"B5:L74"の中の5行目）が処理されるはず。
そもそも、こんな感じではいけないのでしょうか。
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
ありがとうございます。
教えていただいたおかげで、文字の入ったものを消すことができました。
あと、ややこしくしてしまい申し訳ございません。
Oのシート、質問とまったく関係ありません。
もし、私が的外れなことを言っていたら、申し訳ございません。
こちらこそ失礼しました。別のブックから、と書いてあるのを見落としていました。
ただ、言いたかったのは、コピーしてからクリアして詰める、じゃなくて、
最初から必要な行を選びながらコピーする手もあるのでは、ということです。
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
思った通りにできました！
ありがとうございました。
0
おそらく一番の原因はTumeruの方ですね。
現在のコードを実行すると、
・5行目→6行目にコピーし、5行目を削除
・6行目→7行目にコピーし、6行目を削除
といった具合に繰り返されてしまい、結果として途中のデータはすべて消去され、最終行に5行目のデータが残るのみ、という挙動をしています。
このあたりの不具合は、F8によるステップ実行などを使えるようになると、容易に発見できるようになると思います。
肝心の解決策については色々なやり方がありますが、まずは素直に逆順ループをして、空白行を削除していくのが良いと思います。
VBA
1Sub Tumeru() 2 3For k = Range("B" & Rows.Count).End(xlUp).Row To 5 Step -1 4 If (Range("B" & k) = "") Then 5 6 Range("B:L").Rows(k).Delete Shift:=xlUp 7 8 End If 9Next k 10 11End Sub
【追記】
上記のコードは単純ですが、件数が多い場合はとんでもなく遅くなります。
そうした遅さに耐えられなくなった場合は、例えば以下のようにDelete処理を一回にまとめるとはやいです。
VBA
1Sub Tumeru() 2 3Dim Target As Range 4For k = 5 To Range("B" & Rows.Count).End(xlUp).Row 5 If (Range("B" & k) = "") Then 6 7 If Target Is Nothing Then 8 9 Set Target = Range("B:L").Rows(k) 10 11 Else 12 13 Set Target = Union(Target, Range("B:L").Rows(k)) 14 15 End If 16 17 End If 18Next k 19 20Target.Delete shift:=xlUp 21 22End Sub
投稿2021/02/20 02:35
編集2021/02/20 07:53
総合スコア364
ありがとうございます。
書式を消さずに空白を詰めたいので、教えていただいたコードのDeleteを、ClearContentsに変えればできるかと思って実行したところ、「アプリケーション定義またはオブジェクト定義エラーです」と出てしまいました。
説明が足りなく申し訳ございません。
よろしければ、ご教授願います。
私の書いたコードの場合「空白行をDeleteして、削除された分を上方向に詰める」というつくりなので、そもそもClearContentsしても何も起きないと思います。
そしてClearContentsでそのエラーが出るのは、申し訳ないですがよくわかりません。考えられることは「shift:= xlUp」をそのままにしてしまっている、くらいでしょうか。
あなたの回答
tips
プレビュー
