VBA100本ノック10本目：行の削除
出題内容
画像のように「受注」シートに今月の受注データがあります。
受注数が空欄かつ備考欄に「削除」または「不要」の文字が含まれている行を削除してください。
行の削除は行全体を削除してください。
サンプルでは5行目と10行目を削除
自分の解答
Sub vba10()
Sheets("受注").AutoFilterMode = False '①
With Sheets("受注").Range("A1")
.AutoFilter field:=3, Criteria1:=""
.AutoFilter field:=4, Criteria1:="*削除*", _
Operator:=xlOr, Criteria2:="*不要*"
.CurrentRegion.Offset(1, 0).EntireRow.Delete
.AutoFilter
End WithEnd Sub
修正箇所
①処理開始前にフィルターを解除しておくコードを追加。
Offset後に削除している為、一行下の空行も削除している。
問題がある場合はResizeを使うかIntersectで対応する。
ExcelにVBAでパスワードをかける
Excelを開いた時にパスワードを入力させ、一致しなかった場合は自動で閉じる。
Sub pw()
Dim st As String
Dim i As Long
For i = 1 To 3
On Error GoTo myError
st = InputBox("パスワードを入力してください") '1234
If st = 1234 Then
Exit For
Else
MsgBox "パスワードが違います"
If i = 3 Then
MsgBox "ブックを閉じます"
ThisWorkbook.Close savechanges:=True
End If
End If
Next i
MsgBox "パスワードを認証しました"
Exit Sub
myError: ThisWorkbook.Close savechanges:=True 'or False
End Sub
ThisWorkbookにWorkbook_Openと入力することで、ブックを開いた際に処理を始めることができる。
フィルター→新規ブックにコピペ→同じ階層に保存
キャリアがドコモとなっているデータを抽出して、新しいブックとして保存する。
保存先はマクロブックと同じ階層。「処理済」というフォルダを作成してその中に保存する。
Sub wrk()
Dim wb As Workbook
Dim st As String
Dim strPath As String
'同じ階層に「処理後」というフォルダを作成する
strPath = ThisWorkbook.Path & "￥処理後"
If (Dir(strPath, vbDirectory) = "") Then
MkDir (strPath)
End If
st = "ドコモ"Sheets("コピペ用").Cells.Clear
Sheets("データ").AutoFilterMode = False'フィルターでデータ抽出
With Sheets("データ").Range("A1").AutoFilter field:=11, Criteria1:=st
.CurrentRegion.Copy
Sheets("コピペ用").Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.AutoFilterEnd With
'抽出したデータを新しいブックにして保存
Sheets("コピペ用").Copy
Set wb = ActiveWorkbook
With wb
.Sheets(1).name = st 'シート名変更
.SaveAs (ThisWorkbook.Path & "￥処理後￥" & st) 'マクロブックと同じ階層
.Close savechanges:=True '保存して閉じる
End With
End Sub
使用しているサンプルデータはこちら「なんちゃって個人情報」
複数ブックを編集
内容
ブックA.Sheet1のA列に入力してあるブック名を開き、B列で指定しているシートに対して処理を行う。
A列に入力してある各ブックは、ブックAと同じ階層に保存してある。
コード
Sub wrk()
Dim wb As String
Dim ws As String
Dim openBook As Workbook
Dim i As Long
Dim LastRow As Long
'一番左のシートの1列目の最終行番号
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
'開きたいブック名
wb = ThisWorkbook.Sheets(1).Cells(i, 1)
'開きたいシート名
ws = ThisWorkbook.Sheets(1).Cells(i, 2)
'開いたブックを格納
Set openBook = Workbooks.Open(ThisWorkbook.Path & "￥" & wb)
'開いたブックopenBookに対しての処理
'=======================
'シートを選択
openBook.Sheets(ws).Select'=======================
'保存して閉じる
openBook.Close savechanges:=True
Next i
MsgBox "完了"
End Sub
解説
A列の最終行を取得し、For～Nextで全データに対して処理を行っていく。
最終行について
'一番左のシートの1列目の最終行番号
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
データが入力されているシートや列を指定する場合は、赤字の部分を書き換えてください。
（例）データという名前のシートの2行目のデータを使用する場合
LastRow = Sheets("データ").Cells(Rows.Count, 2).End(xlUp).Row
参照するデータについて
'開きたいブック名
wb = ThisWorkbook.Sheets(1).Cells(i, 1)
'開きたいシート名
ws = ThisWorkbook.Sheets(1).Cells(i, 2)
こちらも最終行取得と同様に、赤字部分を書き換えてください。
VBA100本ノック9本目：フィルターコピー
出題内容
「成績表」シートに5教科の成績とG列に合否判定があります。
「合格者」シートを新規作成し、合格者の氏名だけをA列に列挙してください。
※点数は非公開なので「合格者」シートには間違っても出力しないでください。
※何度でも実行できるようにしてください。
自分の解答
Sub vba9()
Dim trgtShName As String
Dim flg As Boolean
Dim ws As Worksheet
trgtShName = "合格者"
'対象シートがあった場合True
For Each ws In ThisWorkbook.Worksheets
If ws.Name = trgtShName Then
flg = TrueSheets(trgtShName).Cells.Clear '①
Exit For
End If
Next
'フラグがFalseだった場合シートを作成
If flg = False Then
Worksheets.Add.Name = trgtShName
End If
Sheets("成績表").AutoFilterMode = False '②
With Sheets("成績表").Range("A1")
.AutoFilter field:=7, Criteria1:="合格"
.CurrentRegion.Offset(1, 0).Resize(, 1).Copy
Sheets("合格者").Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.AutoFilter
End WithEnd Sub
解答確認後二か所修正。
①元データが残っている可能性がある為、データクリアをしてから作業を始める。
②作業前にフィルター解除。
模範解答
Sub VBA100_09_01()
Dim wsIn As Worksheet
Dim wsOut As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("合格者").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set wsIn = Worksheets("成績表")
Set wsOut = Worksheets.Add(After:=wsIn)
wsOut.Name = "合格者"
wsIn.AutoFilterMode = False
With wsIn.Range("A1").CurrentRegion
.AutoFilter Field:=7, Criteria1:="合格"
.Columns(1).Copy wsOut.Range("A1")
End With
wsIn.AutoFilterMode = False
End Sub
合格者シートがあるか確認するよりも、合格者シートを削除して作成し直す方がわかりやすそう。
列コピーColumns(1)で問題ない。
④参照元・参照先のトレース
選択しているセルの参照元を表示させる。
改善前
参照元を図形矢印で繋いでいる。
参照元が変わっても矢印が図形の為、参照していないセルと繋いだままになる可能性がある。
改善後
選択範囲の参照元を表示するマクロを構築。
Dim i As Long
For i = 1 To Selection.Count
Selection.Item(i).ShowPrecedents
Next
参照元のトレース：ShowPrecedents
参照先のトレース：ShowDependents
表示させたいセルが毎回同じの場合は、セルを指定しても良い。
Range("C2").ShowPrecedents
選択範囲の参照元と参照先をトレース
クイックアクセスツールバーに埋め込んで使ってます。
Dim i As Long
For i = 1 To Selection.Count
With Selection.Item(i)
.ShowPrecedents '参照元
.ShowDependents '参照先
End With
Next
VBA100本ノック8本目：点数の合否判定
出題内容
「成績表」シートに5教科の成績表があります。
以下の2条件を満たした者が合格となります。
・5教科合計が350点以上
・全ての科目が50点以上
G列に、合格者に対しては「合格」と出力し、不合格は空欄にしてください。
自分の解答
Dim 合計 As Long
Dim i As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
合計 = WorksheetFunction.Sum(Range("B" & i & ":" & "F" & i))
If Cells(i, 2) >= 50 And Cells(i, 3) >= 50 And Cells(i, 4) >= 50 _
And Cells(i, 5) >= 50 And 合計 >= 350 Then
Cells(i, 7) = "合格"
Else
Cells(i, 7) = ""
End If
Next i
解説
列・行に二重ループを作成するとみやすい。
Sub VBA100_08_01()
Dim ws As Worksheet
Set ws = Worksheets("成績表")Dim i As Long, j As Long, t As Long
For i = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
t = 0
For j = 2 To 6
If ws.Cells(i, j) < 50 Then
t = 0
Exit For
End If
t = t + ws.Cells(i, j)
Next
ws.Cells(i, 7) = ""
If t >= 350 Then
ws.Cells(i, 7) = "合格"
End If
Next
End Sub
Exit For を使うことでループから抜けることができる。
If ws.Cells(i, j) < 50 Then なら t=0 となりExit For
ws.cells(i,7) = "" へ移動する。
