【VBA】もし、値が0だったら左のセルと合わせて削除したい

グラフ作成用のデータです。XYを横に並べて入力しています。

Y列（B・D・F列）が”0”の場合、X列（A・C・E列）とともに削除して上方向にシフトしたい。（添付画像でグレーに塗りつぶしてある範囲）

これが数百あるため、自動処理をしたいのですが、VBA全くの初心者です。
説明もわかりにくくてすみません。どなたかわかりやすく教えていただきたいです。
よろしくお願いいたします。

Excel2016使用です。

質問者からの補足コメント

• Qchan1962さん、こんにちは。
  
  試したところ一瞬でできたので目を疑いました。
  ありがとうございます。
  
  数百あるというのは、シートを増やすのではなく、一つのシートで横に続けています。
  サンプルは3列でしたがMAX列までできれば助かります。
  
  お手数ですがよろしくお願いします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2023/04/20 11:15

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2023/04/20 10:47

こんにちは

＞VBA全くの初心者です
自身で組み込み出来ますか・・・
＞数百あるため
数百に対応する為の処理は出来ますか・・
シートのコピーして行うのでしょうか？

取り合えず　示されている表組を対象に
（B・D・F列）の各セルの値が”0”の場合
削除して上方に詰めるコードです

データを操作して書き直すのではない方法ですので元データのシート自体変更されてしまいます　コピーシートなどで試してください
元データを残したい場合は別法になります

Sub sample()
Dim col As Variant
Dim i As Long
Dim DelRng As Range
For Each col In Array("B", "D", "F")
For i = 4 To Cells(Rows.Count, col).End(xlUp).Row
If Cells(i, col) = "0" Then
If DelRng Is Nothing Then
Set DelRng = Cells(i, col).Offset(, -1).Resize(, 2)
Else
Set DelRng = Union(DelRng, Cells(i, col).Offset(, -1).Resize(, 2))
End If
End If
Next
If Not DelRng Is Nothing Then
DelRng.Delete Shift:=xlUp
Set DelRng = Nothing
End If
Next
End Sub

この回答へのお礼

うまくいきました！

お礼日時：2023/04/20 13:20

No.3 回答者： Qchan1962 回答日時： 2023/04/20 12:12

サンプルは汎用性の低いコードになっています

Array("B", "D", "F")の部分にArray("B", "D", "F", "H", "J"・・・)と加えるか
必ず2列（対象は1列飛ばし）であるなら

For Each col In Array("B", "D", "F")　を　下記に一行書き直します

For col = 2 To Cells(4, Columns.Count).End(xlToLeft).Column Step 2

４行目が最終列を取得する対象行です
2列目から１つ飛ばしに　2・4・６・８・１０・・・・列が "0"検証列になります

この回答へのお礼

おかげさまでうまくいきました！
今まで手作業でやっていました＞＜
大変助かりました、ありがとうございました。

お礼日時：2023/04/20 13:19

No.2 回答者： fujillin 回答日時： 2023/04/20 12:00

こんにちは

＞VBA全くの初心者です。
VBAに固執しているのでなければ、関数でも可能ですよ。

スピルが使える 365 あるいは 2021 環境であるなら、簡単で、
ご提示のレイアウトで、H4セルに
=FILTER(A4:A999,OFFSET($A4:$A999,0,INT(COLUMN(B1)/2))<>0,"")
を入力して、H4:M4にフィルコピーすれば、下方にスピルされ、ご提示の結果が得られます。

※ 式中の「999」は最大行範囲としていますので、適当に修正してください。
※ スピルが使えない環境でも関数で可能ですが、少し面倒な数式になります。


どうしてもVBAで行いたい場合は、以下一例です。

Sub Q_13435857()
Dim v, v2()
Dim i As Long, j As Long
Dim k As Long, m As Long

For i = 1 To 5 Step 2
m = Application.Max(Cells(Rows.Count, i).End(xlUp).Row, 4) - 3
v = Cells(4, i).Resize(m, 2).Value
ReDim v2(1 To m, 1 To 2)
k = 1
For j = 1 To m
If v(j, 2) <> 0 Then
v2(k, 1) = v(j, 1)
v2(k, 2) = v(j, 2)
k = k + 1
End If
Next j
Cells(4, i + 7).Resize(m, 2).Value = v2
Next i
End Sub

この回答へのお礼

fujillinさま

ありがとうございました。
関数でもできるのですね。
勉強になります。

お礼日時：2023/04/20 13:20