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やっていることは削除とほぼ変わりません。
コメント