PCメモ

Excelを中心とした業務改善の記録

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と入力することで、ブックを開いた際に処理を始めることができる。

f:id:abv72:20210814225334p:plain

 

 

フィルター→新規ブックにコピペ→同じ階層に保存

キャリアがドコモとなっているデータを抽出して、新しいブックとして保存する。

保存先はマクロブックと同じ階層。「処理済」というフォルダを作成してその中に保存する。

f:id:abv72:20210813170145p:plain

 

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
  .AutoFilter

 End 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列で指定しているシートに対して処理を行う。

f:id:abv72:20210808151503p:plain

A列に入力してある各ブックは、ブックAと同じ階層に保存してある。

f:id:abv72:20210808151628p:plain

コード

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で全データに対して処理を行っていく。

f:id:abv72:20210808152613p:plain

最終行について

'一番左のシートの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本目:フィルターコピー

excel-ubara.com

出題内容

「成績表」シートに5教科の成績とG列に合否判定があります。
「合格者」シートを新規作成し、合格者の氏名だけをA列に列挙してください。
※点数は非公開なので「合格者」シートには間違っても出力しないでください。
※何度でも実行できるようにしてください。

f:id:abv72:20210711170925p:plain

 

自分の解答

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 = True

   Sheets(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 With

End 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)で問題ない。

④参照元・参照先のトレース

選択しているセルの参照元を表示させる。

改善前

参照元を図形矢印で繋いでいる。

参照元が変わっても矢印が図形の為、参照していないセルと繋いだままになる可能性がある。

f:id:abv72:20210612182647p:plain

 改善後

選択範囲の参照元を表示するマクロを構築。

Dim i As Long
For i = 1 To Selection.Count
 Selection.Item(i).ShowPrecedents
Next

 

参照元のトレース:ShowPrecedents
参照先のトレース:ShowDependents

 

表示させたいセルが毎回同じの場合は、セルを指定しても良い。

Range("C2").ShowPrecedents

f:id:abv72:20210612183000p:plain

選択範囲の参照元と参照先をトレース
クイックアクセスツールバーに埋め込んで使ってます。

Dim i As Long
For i = 1 To Selection.Count
 With Selection.Item(i)
  .ShowPrecedents  '参照元
  .ShowDependents   '参照先
 End With
Next

 

VBA100本ノック8本目:点数の合否判定

excel-ubara.com

出題内容

「成績表」シートに5教科の成績表があります。
以下の2条件を満たした者が合格となります。
・5教科合計が350点以上
・全ての科目が50点以上
G列に、合格者に対しては「合格」と出力し、不合格は空欄にしてください。

VBA マクロ 100本ノック

自分の解答

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

VBA100本ノック 8本目:点数の合否判定|VBA練習問題

 

Exit For を使うことでループから抜けることができる。

If ws.Cells(i, j) < 50 Then なら t=0  となりExit For
ws.cells(i,7) = "" へ移動する。

③散乱する入力欄をまとめる

散乱する手入力欄を一か所にまとめる

改善前

手入力箇所はA・C・Gのみ。

他の項目には関数が入っていて自動計算される仕様。

このままだとどこを入力すればいいのかわからない為、入力が漏れと関数をつぶす可能性がある。

f:id:abv72:20210531202150p:plain

改善後

入力欄を一か所にまとめた。

画像では「参照先のトレース」機能を使っています。

f:id:abv72:20210531202136p:plain

数式タブ→参照元のトレースor参照先のトレース

「トレース矢印の削除」で矢印を削除できる。

ショートカットキーで参照先・元に移動できる。

 参照元に移動:Ctrl+[

 参照先に移動:Ctrl+]

f:id:abv72:20210531204758p:plain