【ExcelVBA】特定の項目を含む列を削除orコピーする方法を解説!

A列にある項目が含まれている場合は削除したい。
また、コピーしたい。

今回は上記のような処理をVBAを使って解説します。

目次

特定の項目を含む列を削除する方法

古い情報を消すときなんかに使えます。

商品売上
2021サンダル1000
2021リュック5000
2020サンダル2000
2020リュック6000
2019サンダル1200

上記のような表があるとします。
一番左の列が2021のものだけ消してみましょう。

Sub 指定文字削除()


'cnumは消したい文字のある列番号
Dim cnum: cnum = 1
Dim buf: buf = "2020"

'指定文字をさがして1以上なら消す
If Not WorksheetFunction.CountIf(Range(Cells(1, cnum), Cells(Rows.Count, cnum).End(xlUp)), buf) = 0 Then

'指定文字でフィルタ
    Range("A1").AutoFilter cnum, buf
   
'ヘッダー以外削除
    Range("A1").CurrentRegion.Select
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Delete Shift:=xlUp
   
    Range("A1").AutoFilter
  
End If

End Sub

CountIfする理由

If Not WorksheetFunction.CountIf(Range(Cells(1, cnum), Cells(Rows.Count, cnum).End(xlUp)), buf) = 0 Then

上記のようにCountIfで存在している確認しています。
なぜかと言えば楽だからです。
使い慣れたCountIfで、0かどうか確認しているだけですからね。

もし、消したい文字が存在しなかった場合の処理を入れるとすると、、、
考えるだけでだるいです。(もっと簡単な方法があれば教えてください!)

AutoFilterを使っている

AutoFilterを使う理由も楽だからです。
イメージしやすいし使いやすいでしょ。

使い方は

Range.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown)

基本的には

Range.AutoFilter 位置, フィルタしたい文字

と思っておけばOKです。
位置はフィルタ全体からみたカラム番号ですね。
左から数えて何番目かってことです。

また、Range.AutoFilterと入れればリセットされます。

今回は削除したら上にあげている

Delete Shift:=xlUp

この部分ですね。

左にしたい場合はxlToLeftでOKです。

文字をポップアップウィンドウで打ち込む場合

Function 消したい年()

消したい年 = InputBox("年を入れてください。※yyyyの形式で。", "年判定", "2022")
If 消したい年 = "" Then
    MsgBox "何も入力されませんでした。"
    End
End If
End Function

上記のような関数を作っておいて

Sub 指定文字削除()

'cnumは消したい文字のある列番号
Dim cnum: cnum = 1
Dim buf: buf = 消したい年

'指定文字をさがして1以上なら消す
If Not WorksheetFunction.CountIf(Range(Cells(1, cnum), Cells(Rows.Count, cnum).End(xlUp)), buf) = 0 Then

'指定文字でフィルタ
    Range("A1").AutoFilter cnum, buf
   
'ヘッダー以外削除
    Range("A1").CurrentRegion.Select
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Delete Shift:=xlUp
   
    Range("A1").AutoFilter
  
End If
End Sub

特定の項目を含む列をコピーする方法

Sub 指定文字コピー()

Dim cnum: cnum = 1
Dim buf: buf = "2021"

'コピー先のシート名
Dim sh As Worksheet
Set sh = Sheets("貼り付け用")

'指定文字をさがして1以上ならコピーする
If Not WorksheetFunction.CountIf(Range(Cells(1, cnum), Cells(Rows.Count, cnum).End(xlUp)), buf) = 0 Then

'指定文字でフィルタ
    Range("A1").AutoFilter cnum, buf
   
'全部貼り付け先のA1にコピー

    Range("A1").CurrentRegion.Copy sh.Range("A1")
    Range("A1").AutoFilter
  
End If

End Sub

やっていることは削除とほぼ変わりません。

コメント

コメントする

目次
閉じる