iEhohs.com

ウェブ＆システム担当の仕事メモ的なブログ。個人的な記事ばかりです。

2019年7月14日(日)

個人的によく使うExcel VBAのコード覚え書き

開発メモ

VBA開発をする時、基本的で簡単なコードであれば覚えているのですが、たいていググるか昔のファイルを開いてコピペしちゃってます。

それで十分だとは思うのですが、その都度サイトやファイルを開くのがめんどくさいので、この記事にまとめておくことにしました。

完全な個人用ですが、これからVBAを学習する人の参考になればと思います。

ファイルを開く

Dim openFileName As String

If Dir(ThisWorkbook.Path & "\sample.csv") <> "" Then
    Workbooks.Open ThisWorkbook.Path & "\sample.csv"
Else
    openFileName = Application.GetOpenFilename("CSV（カンマ区切り）,*.csv")
    If openFileName <> "False" Then
        Workbooks.Open openFileName
    Else
        MsgBox "キャンセルが押されました。" _
            & vbCrLf & "作業を中止します。"
        Exit Sub
    End If
End If

ブックと同一パスに指定のファイルがあればそのまま開き、無ければポップアップして選択し開く。

ブックを閉じる

Application.EnableEvents = False
ActiveWorkbook.Close SaveChanges:=True

閉じる際に出る何かしらのポップアップを拒否し、保存する場合のコード。

ディレクトリ内のブックを順番に開いて処理

Dim path, fso, file, files
Dim wb As Workbook

path = ThisWorkbook.path & "\サンプルフォルダ"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files

For Each file In files
    Set wb = Workbooks.Open(file)
    /* 各ブックに対する処理 */
    Application.EnableEvents = False
    ActiveWorkbook.Close SaveChanges:=True
Next file

VBA：フォルダ内のファイルを順次処理を参考にしました。

複数のExcelブックを1つにまとめる時に使えます。

名前を付けて保存

Dim saveFile As String
Dim saveName As String

saveName = "サンプル"

saveFile = Application.GetSaveAsFilename(saveName, FileFilter:="Excelファイル,*.xlsx,すべてのファイル,*.*")
ActiveWorkbook.SaveAs Filename:=saveFile, FileFormat:=xlNormal

'CSVの場合
saveFile = Application.GetSaveAsFilename(sheetName, FileFilter:="CSV（カンマ区切り）,*.csv")
ActiveWorkbook.SaveAs Filename:=saveFile, FileFormat:=xlCSV

ユーザが保存先や名前を自由に決められます。デフォルトでは「サンプル.xlsx」が入力されます。

ブックの操作

/* アクティブなブックを操作する場合 */
ActiveWorkbook.Worksheets(1).Range("A2").Select

/* マクロを動かしているブックを操作する場合 */
ThisWorkbook.Worksheets(1).Range("A2").Select

ワークシートを探す

Dim ws As Worksheet
Dim sheetFlg As Boolean

For Each ws In Worksheets
    If ws.Name = "サンプル" Then
        sheetFlg = True
    End If
Next

指定の名前がついたシートの存在を判定する。

表の最終行を取得し空白行を削除

Dim rowStart As Integer
Dim rowEnd As Integer
Dim colStart As Integer
Dim colEnd As Integer

'空白セルがある場合はここから
ActiveWorkbook.Worksheets(1).Range("A2").Select

rowStart = Selection.Row
rowEnd = Cells.SpecialCells(xlCellTypeLastCell).Row

colStart = Selection.Column
colEnd = Cells.SpecialCells(xlCellTypeLastCell).Column

'空白セルがない場合はここから
ActiveWorkbook.Worksheets(1).Range("A2").Select

startRow = Selection.Row
rowEnd = Selection.End(xlDown).Row

startCol = Selection.Column
rowCol = Selection.End(xlToRight).Column

基本はCtrl + Shift + ↓、あるいはCtrl + Shift + →の操作をした際の最終行・列を取得するが、途中で空白セルがある場合はうまく機能しないためSpecialCellsを使う。

ソート

Worksheets(1).Range(Cells(2, 1), Cells(100, 5)) _
    .Sort Key1:=Worksheets(1).Cells(2, 2), order1:=xlAscending, _
          Key2:=Worksheets(1).Cells(2, 3), order2:=xlDescending

ヘッダー行ではなくデータが始まる行を指定。

xlAscendingが昇順、xlDescendingが降順。

文字列を含んでいるかの分岐

Dim sample As String
Dim testFlg As Boolean

sampleFlg = False
If InStr(sample, "テスト") > 0 Then
    testFlg = True
End If

文字列を含んでいた場合1を返す。含んでいない場合は>を=にすればよい。

配列

Dim sample(3) As String

sample(1) = サンプル1
sample(2) = サンプル2
sample(3) = サンプル3

Excel VBAでは不都合がなければ0ではなく1からスタートすべし。

コピペ

Worksheets(1).Range("A2", "F" & i).Copy
Worksheets(2).Range("A2").PasteSpecial Paste:=xlPasteValues

このような場合、コピペするブックやシートがアクティブになった気がする（うろ覚え）

変数に格納して代入する場合はアクティブなブックやシートは変わらない。

置換

Range("A2", "A" & i).
Replace What:="/", Replacement:="", LookAt:=xlPart

Dim sample As String
sample = Replace(sample, "/", "")

2パターンあり、上はセル範囲の置換、下は変数の置換で使いやすい。

リストを作成する

Dim listName As Name
Dim a As Integer

a = 100

For Each listName In ThisWorkbook.Names
    If listName.Name = "サンプル" Then
        Range("サンプル").Name.Delete
    End If
Next

ActiveWorkbook.Names.Add _
    Name:="サンプル", _
    RefersTo:="=Sheet1!$A$2:$C$" & a

既にリストが存在していれば削除してから、新たにリストを作成する。

罫線を引く

Range("A2", "E50").Borders.LineStyle = xlContinuous

シートを保護・解除する

/* 解除 */
ActiveSheet.Unprotect
/* 保護 */
ActiveSheet.Protect

マクロ実行時のみ保護を解除する

ThisWorkbook.Worksheets("サンプル").Protect UserInterfaceOnly:=True

Withステートメントでコード省略

With ActiveSheet
    .Range("A2").Value = .Range("A1").Value
End With

これはよく使う、というよりも今まで使ってこなくて最近知った方法。

WithでActiveSheetと宣言しておけば、End Withの間は記述しなくてOKというもの。

「.」から記述し始めていますが、アクティブシートのA2にアクティブシートのA1の値を代入するというコードになります。

Do Loopで繰り返し処理

Do Until ActiveCell.Value = ""
    ActiveCell.Borders.LineStyle = xlContinuous
    ActiveCell.Offset(1, 0).Select
Loop

これも基本のキのはずなのに今まで使ってこなかったやつ。ずっとループはForで貫いていました。

Forは回数を指定するのに対し、Doは条件に合うまでループするのが違い。

アクティブセルが空白でなければ（値が入っていれば）罫線を設定し、アクティブセルを1行下にして条件分岐に戻る。アクティブセルが空白であればループを抜けます。

サンプルの場合、アクティブセルを1行動かす記述がないとループから抜け出せないという事態になってしまいます。条件分岐の対象を変えるコードがないといけないというわけですね。

Caseで分岐

Dim sample As String

sample = Application.InputBox("値を入力", "値入力ウィンドウ")

Select Case sample
    Case ""
        MsgBox ("入力なし" & vbCrLf & "処理終了")
        Exit Sub
    Case "False"
        MsgBox ("キャンセルが押されました" & vbCrLf & "処理終了")
        Exit Sub
    Case Else
End Select

文字列の前後にある空白を取り除く

Dim sample As String
sample = " サンプル "
sample = Trim(sample)

シートの枚数を数えて指定のシートをアクティブにする

Dim sheetCnt As Integer
sheetCnt = Worksheets.Count

For i = 1 To sheetCnt
    If sheetName = Worksheets(i).name Then
        Worksheets(i).Activate
        Exit For
    End If
Next

プロシージャを呼び出す

Call sample(aaa, bbb)

Private Sub sample(ByRef aaa As Integer, ByVal bbb As Integer)

()にはそのプロシージャに渡す引数を入力。

Private Subはモジュール内でのみ有効なプロシージャ。モジュールを越える場合はPublic Subにする。

ByRefは参照渡しで呼び出し先での値変更を反映させ、ByValは値渡しで値の変更は反映させない。

TSV、CSVを開き配列に格納する

Dim openFileName As String
Dim strBuf As Variant
Dim strArray As Variant
Dim setRow As Integer

openFileName = Application.GetOpenFilename("テキストファイル (*.txt),*.txt")

'CSVファイルの場合は "CSV（カンマ区切り）,*.csv"
    If openFileName <> "False" Then
        Open openFileName For Input As #1
    Else
        MsgBox "キャンセルが押されました。" _
            & vbCrLf & "作業を中止します。"
        Exit Sub
    End If

setRow = 1
Do Until EOF(1)    
    Line Input #1, strBuf
    If strBuf <> "" Then
        strArray = Split(strBuf, vbTab)
        
        For i = 0 To UBound(strArray)
            Cells(setRow, i+1).Value = strArray(i)
        Next
        setRow = setRow + 1
    End If
Loop
        
Close #1

現時点の日付でマクロ実行ファイルと同じフォルダに保存

Dim thisPath As String
Dim todayDate As String

thisPath = ActiveWorkbook.Path
todayDate = Format(Now, "yyyymmdd")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=thisPath & todaysDate & ".xlsx"
Application.DisplayAlerts = True

日付の計算

Dim setDate As date

setDate = "2020/05/01"
setDate = DateAdd("d", 3, setDate)
MsgBox(setDate)

setDateに３日足す例。

DateAddの引き数を変えることで日数や年・月・日・時・分・秒までいける。

ワークシートを数える

sheetCnt = Worksheets.Count

新規ブックを作成

Workbooks.Add

Tag : , , 作成者 : オクタ゛シヨウヘイ

コメントする

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です