Cyber Design Station - EXCEL VBA 基礎

EXCEL VBA 基礎

以下は、動作保証をしないので、自己責任で確認のこと。プログラム等その他により生じたいかなる損害等その他について、責任を負いませんので、予めご了承してください。

【「フォルダ内情報の取得」 FileSystemObject版】

【「フォルダ内情報の取得」 Dir関数版】

【「セル式を見やすくする処理」 regExp】

【「Find関数処理」 Find関数】

【「CommandBars処理」サブメニューの作成方法】

(予定)セル値・セルの書式・セル式の解析

【「フォルダ内情報の取得」 FileSystemObject版】

■参照設定

FileSystemObjectは参照設定により使用できる。以下のどちらでも使用可能

Windows Script Host Object Model [C:\Windows\SysWOW64\wshom.ocx]

Microsoft Scripting Runtime [C:\Windows\SysWOW64\scrrun.dll]

Option Explicit

Dim i As Long

Const BasePath As String = "G:\電脳設計局"

Sub フォルダ内情報の取得()

'初期化

i = 0

Call GetFolderInfo(BasePath)

End Sub

Public Function GetFolderInfo(ByRef sPath As String) As Boolean

Dim sys As FileSystemObject

Dim objFolders As Folder

Dim objFiles As File

Set sys = New FileSystemObject

For Each objFolders In sys.GetFolder(sPath).SubFolders

Call GetFolderInfo(objFolders.Path)

i = i + 1

Cells(i, 1) = "フォルダ名"

Cells(i, 2) = Right(sPath, Len(sPath) - InStrRev(sPath, "\")) 'フォルダ名

Cells(i, 4) = Left(sPath, InStrRev(sPath, "\") - 1) 'フォルダパス

End If

For Each objFiles In sys.GetFolder(sPath).Files

i = i + 1

'セルに情報設定

Cells(i, 1) = "ファイル名"

Cells(i, 3) = UCase(objFiles.Name) 'ファイル名

Cells(i, 4) = UCase(objFiles.ParentFolder) 'ファイルのあるフォルダパス

Cells(i, 5) = objFiles.DateCreated 'ファイルの作成された日時

Cells(i, 6) = objFiles.DateLastAccessed 'ファイルの最後にアクセスされた日時

Cells(i, 7) = objFiles.DateLastModified 'ファイルの最後に変更された日時

Cells(i, 8) = "'" & Format(objFiles.Size / 1024, "#.0")

End Function

■応用例

セルの部分をクラス（ディクショナリーとコレクション型）にすることで、簡易データベース的使用も可能。

■資料

VBAのヘルプファイルやMSDNなど。

【「フォルダ内情報の取得」 Dir関数版】

Excel VBAを使用 Dir関数は再帰関数によるエラーに注意

Option Explicit

Const BasePath As String = "G:\電脳設計局"

Public Function フォルダ内情報の取得_Dir関数版() As Boolean

Dim tmp As String '変数

Dim tmpPath As String 'Path

Dim sFileName As String 'ファイル名

Dim i As Long 'カウント変数

Dim a As Long 'カウント変数

Dim TargetFolder() As String 'ターゲットとなるフォルダ名

'初期化

i = 0

tmp = ""

Erase TargetFolder

ReDim TargetFolder(1)

'パス設定

tmpPath = BasePath

On Error Resume Next

tmp = Dir(tmpPath & "\", vbDirectory)

'ファイル名とサブフォルダのパス取得

Do While tmp <> ""

'サブフォルダの抽出設定処理

'vbDirectory

If GetAttr(tmpPath & "\" & tmp) = vbDirectory Then ' = を and演算子で調べてもよい

'<> 自分自身のフォルダ and <> １つ上のフォルダ

If tmp <> "." And tmp <> ".." Then

'カウント変数の加算

i = i + 1

'配列の拡大

ReDim Preserve TargetFolder(i)

'サブフォルダの設定

TargetFolder(i) = tmpPath & "\" & tmp

'Debug.Print TargetFolder(i)

End If

tmp = Dir()

Loop

'ファイル名の抽出

For a = 0 To i

If a = 0 Then

'指定フォルダの設定

tmpPath = BasePath

Else

'指定フォルダにサブフォルダがある場合

tmpPath = TargetFolder(a)

End If

'フォルダ内検索してファイルを抽出する処理

sFileName = Dir(tmpPath & "\*.*")

Do While sFileName <> ""

Debug.Print sFileName

sFileName = Dir

Loop

■応用例

動的配列の部分をクラス（ディクショナリーとコレクション型）にすることで、簡易データベース的使用も可能。

■資料

VBAのヘルプファイルやMSDNなど。

【「セル式を見やすくする処理」 regExp】

■参照設定

regExpは参照設定により使用できる

Microsodt VBScript Regular Expressions5.5

Option Explicit

Public Function 指定したセル内のセル式を見やすくする処理() As Boolean

'【基礎】一つのセルに対する処理

'指定したセルにある式の例 =IF(OR(A1=0,A1=1,A1=3),"A","B")

Dim regExp As regExp

Dim SetSelection As Range

Dim item As Range

Dim Match As Variant

Dim Matches As Variant

Dim i As Long

Dim j As Long

Dim c As Long

'Dim sender As String

Dim retstr As Variant

Dim vData As Variant

'生成

Set regExp = New regExp

'パターンの設定

With regExp

.Pattern = "[\(\),]" 'マッチングパターンの例 "[^0-9]" 数字以外 "[0-9]" 数字

.IgnoreCase = True

.Global = True

End With

'セレクションの設定

Set SetSelection = Selection

'式の抽出加工処理

For Each item In SetSelection

i = 1

j = 0

c = 0

If item.HasFormula = True Then

vData = item.Formula

If regExp.test(vData) = True Then

Set Matches = regExp.Execute(vData) ' 検索を実行します。

For Each Match In Matches ' Matches コレクションに対して繰り返し処理を行います。

c = Match.FirstIndex + 1

If Match.Value = "(" Then

j = j + 3

End If

'式の構築

If Trim(VBA.Mid(vData, i, c - i)) <> "" Then

retstr = retstr & VBA.Space(j) & VBA.Mid(vData, i, c - i) & vbCrLf

End If

If Match.Value = ")" Then

j = j - 3

End If

'式の構築

retstr = retstr & VBA.Space(j) & Match.Value & vbCrLf

If Match.Value = "(" Then

j = j + 3

ElseIf Match.Value = ")" Then

j = j - 3

End If

i = c + 1

End If

Debug.Print retstr

End Function

■応用例

パターンを指定することで、いろいろなデータ検証などにも応用ができる。

■資料

VBAのヘルプファイルやMSDNに文法やテクニックがある。アルゴリズムは古典。

【「Find関数処理」 Find関数】

Option Explicit

Private Sub Find関数処理()

Dim TargetRange As Range '次のターゲット

Dim FirstAddress As String '最初の検索結果のアドレス

Dim Target As String

'検索値を設定

Target = Cells(1, 1).Value 'Cells(Y,X).value

Set TargetRange = Worksheets("Sheet1").Range("B10:F56").Find(what:=Target, LookIn:=xlValues, _

LookAt:=xlPart, MatchCase:=False, MatchByte:=False) 'xlPart：部分一致 xlWhole：完全一致

'日付け　.Find(what:=DateValue(Target), LookIn:=xlFormulas

'検索したCellの真横　TargetRange.Offset(0,1)

If TargetRange Is Nothing Then

'検索結果ない

Else

'検索結果ある

'セル位置を変数に設定

FirstAddress = TargetRange.Address

'次の検索を検索対象がなくなるまで処理する

Do

If Not TargetRange Is Nothing Then

'検索結果がある場合

Debug.Print TargetRange.Address

End If

Set TargetRange = Worksheets("Sheet1").Range("B10:F56").FindNext(TargetRange)

Loop While Not TargetRange Is Nothing And TargetRange.Address <> FirstAddress

'Loop Until TargetRange.Address = FirstAddress

End If

End Sub

■応用例

SendKey処理でするTAB移動処理との組み合わせで指定セルのみ入力可能なシート保護の場合の検証など。

■資料

VBAのヘルプファイルやMSDNなど。

【「CommandBars処理」サブメニューの作成方法】

Option Explicit

'新規メニューバーの作成

Sub Menu_Add()

　 '--------------------------------------------------元となるCommandBarsコントロールの生成

Application.CommandBars.Add Name:="New_Bar", _

Position:=msoBarTop, MenuBar:=True

With Application.CommandBars("New_Bar")

.Visible = True

　　 '--------------------------------------------------階層 level 1

.Controls.Add Type:=msoControlPopup

.Controls(1).Caption = "新規メニュー"

With .Controls(1)

　　 '--------------------------------------------------

.Controls.Add Type:=msoControlButton

With .Controls(1)

.Caption = "メニュー１"

.OnAction = "Msg_1"

End With

.Controls.Add Type:=msoControlPopup

With .Controls(2)

.Caption = "メニュー２"

.Controls.Add Type:=msoControlButton 'サブメニューの追加

.Controls(1).Caption = "サブメニュー"

.Controls(1).OnAction = "Msg_2"

End With

　　 '--------------------------------------------------

End With

　　 '--------------------------------------------------階層 level 1

.Controls.Add Type:=msoControlPopup

.Controls(2).Caption = "削除メニュー"

With .Controls(2)

.Controls.Add Type:=msoControlButton

With .Controls(1)

.Caption = "新規メニューの削除"

.OnAction = "Menu_Del"

End With

End Sub

'新規メニューバーの削除

Sub Menu_Del()

Dim Ans As Byte

Ans = MsgBox("新規メニューを削除しますか？", vbYesNo)

If Ans = vbYes Then

Application.CommandBars("New_Bar").Delete

End If

End Sub

'メニュー1 の処理

Sub Msg_1()

MsgBox "メニュー１を処理しました。"

End Sub

'メニュー2 のサブメニューの処理

Sub Msg_2()

MsgBox "メニュー２のサブメニューを処理しました。"

End Sub

■応用例

自動プログラム作成用など。

■資料

VBAのヘルプファイルやMSDNなど。

EXCEL VBA 基礎

【「フォルダ内情報の取得」 FileSystemObject版】

【「フォルダ内情報の取得」 Dir関数版】

【「セル式を見やすくする処理」 regExp】

【「Find関数処理」 Find関数】

【「CommandBars処理」 サブメニューの作成方法】

【「CommandBars処理」サブメニューの作成方法】