2020-08-30

【VBA】フォルダ内のファイル名一覧を取得する（Do～LoopとDir）

VBA

今回はフォルダ内のファイル名一覧を取得した例（Do～LoopとDir）をブログにしたいと思います。
最終的にはシート一覧を取得できるようにして、ユーザーが処理したいブック・シートをコピペで転記できるリスト作成したいです。

Do～Loop
- Do～Loop構文
Dir関数

Do～Loop

Do～Loopの処理は指示した条件が成立するか否かを判断し、繰り返し処理を行うものです。
For～Next、For～Eachなどもありますが条件分岐で判断することが多く、私はよく活用しています。
まずはDo～Loop構文を確認してみます。

Do～Loop構文

構文①
Do [{While or Until} 条件]
処理
Loop
構文②
Do
処理
Loop {While or Until} 条件

構文①では繰り返し処理開始前に条件を確認します。構文②ではその逆で繰り返し処理後に条件を確認します。
{}の中は WhileまたはUntilを記述します。
Whileは条件を満たす間、処理を繰り返し実行します。
Untilは条件を満たすまで、処理を繰り返し実行します。

条件はTrue、Falseを評価する数式を指定します。
私は構文①のDo Whileしか使用しません。うまく活用すれば１つで補間できるはず。です。
以下のxが変数のコードは xが1以下である限り繰り返し、yが変数のコードはyが1より大きくなるまで繰り返します。

    Dim x, i As Variant
    x = 0
    i = 1
        
    Do While x <= 1
        Cells(i, 1).Value = x
        i = i + 1
        x = x + 0.1
    Loop

    Dim y, j As Variant
    y = 0
    j = 1
        
    Do Until y > 1
        Cells(j, 2).Value = y
        j = j + 1
        y = y + 0.1
    Loop

Dir関数

次にDir関数についてです。
Dirはそもそも何のことだろう？と英語に弱い私は疑問思ったので調べると
Directoryの略でしたね（笑）

Dir関数は、指定したファイル属性などと一致するファイル、フォルダの名前を返す関数です。

Dir()を繰り返せばフォルダ内のすべてのファイルについて名前を取得できます。
Dir("C:\"&"*.xls*")でCドライブ直下のExcelファイルすべてについて名前を取得できます。

Do～Loopと組み合わせると下記例の記載となります。

    Dim name As Variant
    name = Dir("C:\" & "*.xls*")
    
    Do While name <> ""
        name = Dir()
    Loop

この二つを組み合わせて、指定のフォルダ内にあるファイルに対し繰り返し処理を作成する予定です。

2020-08-23

【VBA】フォルダ更新確認自動化ツール

VBA

本日はフォルダ内へサブフォルダが追加されたかを日々確認できるツールを作成してみました。

ツール作成の背景
ツールの考え方
ツール全体像
- コードの説明

ツール作成の背景

私の関わる業務では作業者の方がデータ取得→サーバへ格納をしていただいておりました。
そのデータを日々確認していたのですが、毎回フォルダを見に行くのが面倒で、、、
どうにか自動化できないかと試行錯誤した結果が今回のツールになります。

同じ悩みを持っている方がいらっしゃればご活用いただければと思います。

ツールの考え方

データ格納先が今後増えること、そもそも現時点で複数ある事から
Excel上で親フォルダの数とパスを指定してサブフォルダの名前やパスを取得しに行くツールとしています。
あるルールさえ守ればVBAコードのメンテナンスフリーを目指しています。

動作前
f:id:hanabusa2525:20200823172051p:plain
動作後

更新箇所の取得＆見える化ができました。

ツール全体像

頑張った点を記載したうえでの、ソースコードの全体像になります。
あ、Microsoft Scripting Runtimeのライブラリを有効かしないと使えませんのでご注意を…
（その辺は後々ブログにしていこうと思います。）

コードの説明

シート上で繰り返し数決定

変数：pFlCntにエクセルシートから親フォルダ数を取得し For文の繰り返しに使用しています。
→狙いはコード上での繰り返し数変更をしなくてよくなるように。

追加されたフォルダ名のみ処理

myObjでmyRangeの範囲をFindで検索し、一致した場合は更新しないようにしています。
→新規に追加されたフォルダのみを取得することが目的のためです。

通常フォルダのみの取得

変数：folderAttributesが 16の時のみ処理へ入るようにしています。
→通常フォルダのみを取得することを目的としているためです。

更新箇所通知

msgへchangeflg()がTrueとなった親フォルダ名を格納し、MsgBoxでどの親フォルダに更新があったかを通知しています。
→ユーザとの対話のためのつもり…です。

Sub GetSubFolderName()

    Dim fso As FileSystemObject
    Set fso = New FileSystemObject

    Dim pFolder As Folder: Dim fl As Folder
    Dim pFolderName As String: Dim folderName As String: Dim folderPath As String
    
    Dim pFlCnt As Long: Dim i As Long: Dim j As Long: Dim cnt As Long
    Dim tSRow As Long: Dim tERow As Long: Dim tSCol As Long: Dim folderAttributes As Long
    Dim mywb As Workbook: Dim myws As Worksheet
    
    Dim myRange As Range: Dim myObj As Range
    
    Dim changeflg() As Boolean
    Dim msg As String
    
    Set mywb = ThisWorkbook
    Set myws = mywb.Worksheets("main")
    
    pFlCnt = myws.Cells(2, 4).Value
    
    ReDim changeflg(pFlCnt) As Boolean
    
    For i = 1 To pFlCnt
        j = 0: tSRow = 6: tSCol = 5 * (i - 1) + 2               '初期化
        tERow = myws.Cells(tSRow, tSCol + 1).End(xlDown).Row    'セルの一番下の行取得
        
        '初期空欄時
        If tERow = Rows.Count Then
            tERow = 6
            cnt = 0
        Else
            cnt = myws.Cells(tERow, tSCol).Value
        End If
        
        pFolderName = myws.Cells(4, 5 * (i - 1) + 4).Value      '親フォルダのパス取得
        Set pFolder = fso.GetFolder(pFolderName)                '親フォルダを取得

        '検索対象設定
        Set myRange = myws.Range(myws.Cells(tSRow, tSCol + 1), myws.Cells(tERow, tSCol + 1))
        myws.Cells(tSRow, tSCol).Resize(tERow, 4).Interior.ColorIndex = 0
        
        For Each fl In pFolder.SubFolders                       'サブフォルダの一覧を取得
            folderName = fl.Name                                'フォルダ名の取得
            folderPath = fl.Path                                'サブフォルダパスの取得
            folderAttributes = fl.Attributes                    'サブフォルダの属性取得

            Set myObj = myRange.Find(folderName, LookAt:=xlWhole)

            If folderAttributes = 16 Then
                '更新判断
                If myObj Is Nothing Then
                'cnt,フォルダ名,フォルダパス記載
                    cnt = cnt + 1
                    j = j + 1
                    myws.Cells(tERow + j, tSCol).Value = cnt
                    myws.Cells(tERow + j, tSCol + 1).Value = folderName
                    myws.Cells(tERow + j, tSCol + 2).Value = folderPath
                    myws.Cells(tERow + j, tSCol + 3).Value = Date
                    '更新したセルへ色を付ける
                    myws.Cells(tERow + j, tSCol).Resize(, 4).Interior.Color = RGB(204, 255, 255)
                    
                    changeflg(i) = True                         'フラグ立てる
                End If
            End If
        Next
    Next i
    
    '更新通知
    For i = 1 To pFlCnt
        If changeflg(i) = True Then
            msg = msg & "親フォルダ" & i & "のサブフォルダに更新がありました。" & vbCrLf
        End If
    Next i
    
    If msg <> "" Then
        MsgBox (msg)
    End If
        
    ' 後始末
    Set fso = Nothing
    Set pFolder = Nothing
    Set mywb = Nothing
    Set myws = Nothing

End Sub

2020-08-22

シート間貼り付けコードの説明

VBA

先日のコードについて補足していこうと思います。

ワークシートをオブジェクト変数へ代入
Range＋Cellsで任意の範囲の値を転記
For文繰り返しで列方向の値を行方向に転記

ワークシートをオブジェクト変数へ代入

以下ではDim ** As Worksheet　で宣言した、ワークシートのオブジェクト変数へシート名を指定して代入しています。
オブジェクト変数へ代入することで、コード内で何度もWorksheets("***")を記載しなくてよくなります。

Set houseHoldWs = ThisWorkbook.Worksheets("家計簿")
Set nowHouseholdWs = ThisWorkbook.Worksheets("家計簿当月表示")

ワークシートのようなオブジェクトを変数へ代入するためには、普通に＝ではなく、変数の前にSetを書く必要があります。
ここでは「家計簿」と「家計簿当月表示」をオブジェクト変数に代入しています。

Range＋Cellsで任意の範囲の値を転記

以下ではRange(A1:B10)などの範囲指定の代わりに、Range(Cells(x,y),Cells(a,b))の記載で範囲を任意のサイズにしております。
Cells(x,y).Resize(a,b)でも同じ記述できますね。
Resizeに慣れていないため、Range+Cellsを使用していますがこっちのほうがいいですね…

nowHouseholdWs.Range(nowHouseholdWs.Cells(cumagoSRow, cumagoSCol), nowHouseholdWs.Cells(cumagoERow, cumagoECol)).Value = _
nowHouseholdWs.Range(nowHouseholdWs.Cells(cumSRow, cumSCol), nowHouseholdWs.Cells(cumERow, cumECol)).Value

小ネタを少し…
ws指定は ws.Range(ws.Cells(…　とRangeとCells両方に記載しないとバグります。昔それで少し時間使いました。

For文繰り返しで列方向の値を行方向に転記

Cells(i,1).value = Cells(1,i).valueで記載すれば、左へ右を代入するので列方向の値を行方向に転記しています。
VBAではよくやること？ですかね

For i = targetSCol To targetECol
　　nowHouseholdWs.Cells(i + 1, tSCol).Value = houseHoldWs.Cells(targetRow, i).Value
Next i

2020-08-16

シート間貼り付け

VBA

VBAでシート間をまたいで貼り付けるコードを記述しました。
後で編集しやすいように、宣言しているため少し冗長ですが…

宣言まとめて同じ型でできる方法なかったっけ・・・？

後日考え方などについて記述しようと思います。

Option Explicit

Sub Household()

    Dim houseHoldWs As Worksheet: Dim nowHouseholdWs As Worksheet
    
    Dim tSRow As LongPtr: Dim tSCol As LongPtr: Dim tERow As LongPtr
    Dim targetRow As Long: Dim targetSCol As LongPtr: Dim targetECol As LongPtr
    Dim cumSRow As LongPtr: Dim cumSCol As LongPtr: Dim cumERow As LongPtr: Dim cumECol As LongPtr
    Dim cumagoSRow As LongPtr: Dim cumagoSCol As LongPtr: Dim cumagoERow As LongPtr: Dim cumagoECol As LongPtr
    Dim targetMCol As LongPtr: Dim targetMonth As String
    Dim rc As Integer: Dim i As LongPtr
    
    'シートセット
    Set houseHoldWs = ThisWorkbook.Worksheets("家計簿")
    Set nowHouseholdWs = ThisWorkbook.Worksheets("家計簿当月表示")
        
    '初期値設定
    tSRow = 3: tSCol = 3: tERow = 10: cumSRow = 3: cumSCol = 6: cumERow = 10: cumECol = 7
    cumagoSRow = 3: cumagoSCol = 10: cumagoERow = 10: cumagoECol = 11
    targetSCol = 2: targetECol = 9: targetMCol = 1
        
    '転記対象の行取得
    targetRow = ActiveCell.Row
    targetMonth = houseHoldWs.Cells(targetRow, targetMCol).Value
    
    rc = MsgBox("転記対象は" & targetMonth & "です。", vbOKCancel)
    
    '処理中断
    If rc = 2 Then: Exit Sub: End If

    '前月累計転記
    nowHouseholdWs.Range(nowHouseholdWs.Cells(cumagoSRow, cumagoSCol), nowHouseholdWs.Cells(cumagoERow, cumagoECol)).Value = _
    nowHouseholdWs.Range(nowHouseholdWs.Cells(cumSRow, cumSCol), nowHouseholdWs.Cells(cumERow, cumECol)).Value
    
    '当月家計簿転記
    For i = targetSCol To targetECol
        nowHouseholdWs.Cells(i + 1, tSCol).Value = houseHoldWs.Cells(targetRow, i).Value
    Next i
End Sub