Excel VBA ファイル操作

Option Explicit
Option Base 1


Sub ファイル名先頭文字でカウント()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim ファイルオブジェクト As Object
   Dim フォルダパス As String
   Dim ファイルパス As String
   Dim 接頭辞カウント(1000, 2) As Variant
   Dim 接頭辞辞書 As Object '★連想配列
   Dim 拡張子 As String
   Dim 桁数 As Integer
   Dim ファイル名 As String
   Dim 接頭辞 As String
   Dim カウンタ As Integer
   Dim 最終行 As Integer

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set 接頭辞辞書 = CreateObject("Scripting.Dictionary") '★連想配列の定義
   
   拡張子 = ThisWorkbook.Worksheets("スタート").Range("A2").Value
   桁数 = ThisWorkbook.Worksheets("スタート").Range("B2").Value
   カウンタ = 0
   
   '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
   ChDir ThisWorkbook.Path 'デフォルトのパスをこのExcelファイルのフォルダに変更
   ファイルパス = Application.GetOpenFilename(",*." & 拡張子)
   
   '[ファイルを開く]で「キャンセル」した場合は、処理を終了
   If ファイルパス = "False" Then End
   
   'ファイルパスから、フォルダパスを取得
   フォルダパス = ファイルシステムオブジェクト.GetParentFolderName(ファイルパス)

   '上で指定したフォルダ内の、全ての対象拡張子を検索
    For Each ファイルオブジェクト In ファイルシステムオブジェクト.GetFolder(フォルダパス).Files

      If 拡張子 = ファイルシステムオブジェクト.GetExtensionName(ファイルオブジェクト.Name) Then

         ファイル名 = ファイルオブジェクト.Name
         接頭辞 = Left(ファイル名, 桁数)
         
         If 接頭辞辞書.Exists(接頭辞) = False Then
            カウンタ = カウンタ + 1
            接頭辞辞書.Add 接頭辞, カウンタ
            接頭辞カウント(カウンタ, 1) = 接頭辞
            接頭辞カウント(カウンタ, 2) = 1
         Else
            接頭辞カウント(接頭辞辞書.Item(接頭辞), 2) = 接頭辞カウント(接頭辞辞書.Item(接頭辞), 2) + 1
         End If

      End If
   Next ファイルオブジェクト
   
   '既存データの2行目以降を行削除する
   Worksheets("接頭辞カウント").Activate
   'A 列(1列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   If 最終行 > 1 Then
      Rows(2 & ":" & 最終行).Delete Shift:=xlUp '単純な Cells.Clear だとムダな空白行が残ってしまう
   End If
   '集計結果を登録
   ThisWorkbook.Worksheets("接頭辞カウント").Range("A1").Value = "接頭辞"
   ThisWorkbook.Worksheets("接頭辞カウント").Range("B1").Value = "カウント"
   ThisWorkbook.Worksheets("接頭辞カウント").Range("A2").Resize(カウンタ, 2) = 接頭辞カウント
   'カウントの降順でソート
   Range("A1").CurrentRegion.Sort _
      Key1:=Range("B2"), Order1:=xlDescending, _
      Header:=xlYes

   Set 接頭辞辞書 = Nothing '★連想配列を削除
   Set ファイルシステムオブジェクト = Nothing
   MsgBox "終了しました"

End Sub

Option Explicit

Sub Excelブックの串刺し集計�@()

Dim フォルダパス As String
Dim ブック指定 As Variant
Dim 行 As Integer
Dim 列 As Integer
Dim ファイル As Integer
Dim データ(1000, 5) As Variant

   '画面表示を止めて、処理を高速化
   Application.ScreenUpdating = False
   
   '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
   フォルダパス = Application.GetOpenFilename("Excelファイル,*.xls")
   
   '[ファイルを開く]で「キャンセル」した場合は、処理を終了
   If フォルダパス = "False" Then End
   
   'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
   フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))

   'Excelのシート構成が違ってもエラーで止まらないようにする。
    On Error Resume Next

   '上で指定したフォルダ内の、全てのExcelファイルを対象に検索
   With Application.FileSearch
       .LookIn = フォルダパス
       .Filename = "*.xls"
   
      If .Execute > 0 Then
         For ファイル = 1 To .FoundFiles.Count
            Workbooks.Open Filename:=.FoundFiles(ファイル), UpdateLinks:=0, ReadOnly:=True
             'リンクを更新せずに、読み取り専用で、ブックを開く
            データ(ファイル, 1) = ActiveWorkbook.Worksheets("売上").Range("A11").Value
            データ(ファイル, 2) = ActiveWorkbook.Worksheets("損益").Range("C2").Value
            
            For 行 = 1 To 3
                データ(ファイル, 行 + 2) _
                = ActiveWorkbook.Worksheets("棚卸資産").Range("CB17").Cells(行 * 8, 1).Value
            Next 行
            
            ActiveWorkbook.Close False
         Next ファイル
      End If
   End With
   
  
   ThisWorkbook.Worksheets("sheet1").Activate
   
   For 行 = 1 To ファイル
     For 列 = 1 To 5
       ThisWorkbook.Worksheets("sheet1").Range("A5").Cells(行, 列) = データ(行, 列)
     Next 列
   Next 行
   
   Application.ScreenUpdating = True

End Sub

With Application.FileSearch
    .LookIn = "c:\my documents"
    .FileType = msoFileTypeExcelWorkbooks
    .Execute
End With

With Application.FileSearch
    .NewSearch
    .LookIn = "C:\My Documents"
    .SearchSubFolders = True 'サブ・フォルダも含めて検索します。
    .FileName = "Run"
    .MatchTextExactly = True
    .FileType = msoFileTypeAllFiles
End With

With Application.FileSearch
    If .Execute() > 0 Then
        MsgBox .FoundFiles.Count & " 個のファイルが見つかりました。"           
        For i = 1 To .FoundFiles.Count
            MsgBox .FoundFiles(i)
        Next i
    Else
        MsgBox "検索条件を満たすファイルはありません。"
    End If
End With

With Application.FileSearch
    .LookIn = "C:\My Documents"
    .FileName = "cmd*"
    If .Execute(SortBy:=msoSortbyFileName, _
    SortOrder:=msoSortOrderAscending) > 0 Then
        MsgBox "見つかったファイルは  " & .FoundFiles.Count & _
            "  ファイルです。"
        For i = 1 To .FoundFiles.Count
            MsgBox .FoundFiles(i)
        Next i
    Else
        MsgBox "ファイルが見つかりません。"
    End If
End With

Option Explicit

Dim ファイル As Integer
Dim データ(1000, 5) As Variant
Dim 行 As Integer


Sub Excelブックの串刺し集計�A()

Dim フォルダパス As String
Dim 列 As Integer
Dim 拡張子 As String

   '画面表示を止めて、処理を高速化
   Application.ScreenUpdating = False
   
   '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
   フォルダパス = Application.GetOpenFilename("Excelファイル,*.xls")
   拡張子 = "xls"

   '[ファイルを開く]で「キャンセル」した場合は、処理を終了
   If フォルダパス = "False" Then End
   
   'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
   フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))
   '最後の\付き
   
    Call フォルダ内のファイル取得(フォルダパス, 拡張子) '★★★★★ 

   
   ThisWorkbook.Worksheets("sheet1").Activate
   
   For 行 = 1 To ファイル
     For 列 = 1 To 5
       ThisWorkbook.Worksheets("sheet1").Range("A5").Cells(行, 列) = データ(行, 列)
     Next 列
   Next 行
   
   Application.ScreenUpdating = True

End Sub


'★★★★★
Private Sub フォルダ内のファイル取得(フォルダパス As String, 拡張子 As String)

    'Dir 関数を使用して､
    '指定されたフォルダで見つかったExcelブックを開きます。

    Dim ファイル名 As String   'Dirの返り値を一時的に保存
    
    '初期化
    ファイル名 = Dir(フォルダパス & "*." & 拡張子, vbDirectory)
    ファイル = 1
    
    'Excelのシート構成が違ってもエラーで止まらないようにする。
    On Error Resume Next

    'ファイル名をリストアップ
    While ファイル名 <> ""
        
        Workbooks.Open Filename:=ファイル名, ReadOnly:=True

        データ(ファイル, 1) = ActiveWorkbook.Worksheets("売上").Range("A11").Value
        データ(ファイル, 2) = ActiveWorkbook.Worksheets("損益").Range("C2").Value
            
        For 行 = 1 To 3
            データ(ファイル, 行 + 2) _
            = ActiveWorkbook.Worksheets("棚卸資産").Range("CB17").Cells(行 * 8, 1).Value
        Next 行
            
        ActiveWorkbook.Close False
        ファイル = ファイル + 1
            
        ファイル名 = Dir()
    Wend
    
End Sub

Dim MyFile, MyPath, MyName
' "WIN.INI" が存在する場合、そのファイル名を返します(Microsoft Windows の場合)。
MyFile = Dir("C:\WINDOWS\WIN.INI")    

' 指定した拡張子を持つファイル名を返します。複数の *.INI ファイル
' が存在すると、最初に見つかったファイル名を返します。
MyFile = Dir("C:\WINDOWS\*.INI")

' 引数を指定せずに再度 Dir 関数を呼び出すと、
' 同じフォルダにある次の *.INIファイルを返します。
MyFile = Dir

' 隠しファイル属性を持つ *.TXT ファイルであり、最初に見つかったファイル名を返します。
MyFile = Dir("*.TXT", vbHidden)

' C:\ 内のフォルダの名前を表示します。
MyPath = "c:\"    ' パスを設定します。
MyName = Dir(MyPath, vbDirectory)    ' 最初のフォルダ名を返します。
Do While MyName <> ""    ' ループを開始します。
    ' 現在のフォルダと親フォルダは無視します。
    If MyName <> "." And MyName <> ".." Then
        ' ビット単位の比較を行い、MyName がフォルダかどうかを調べます。
        If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
            Debug.Print MyName        ' フォルダであれば、それを表示します。
        End If
    End If
    MyName = Dir                    ' 次のフォルダ名を返します。
Loop

Option Explicit
Option Base 1

Dim ファイルシステムオブジェクト As Object
Dim フォルダ_オブジェクト As Object
Dim サブフォルダ As Variant
Dim フォルダパス As Variant

Dim 開始日時 As Variant
Dim 終了日時 As Variant

Dim データ(10000, 2) As Variant 'フォルダパス、ファイル数
Dim このExcelが登録されているフォルダパス As String
Dim フォルダ数 As Integer


Sub サブフォルダを含めてファイル数を取得()
   Dim 最終行 As Integer

   開始日時 = Now                ' 開始時刻を変数に格納します。

   ThisWorkbook.Worksheets("Sheet1").Activate
    
'   シートの過去データを削除
   最終行 = Worksheets("Sheet1").UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
   
   If 最終行 > 10 Then
      Rows("11:" & CStr(最終行)).Delete Shift:=xlUp
   End If
   
   このExcelが登録されているフォルダパス = ThisWorkbook.Path
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   フォルダパス = ファイルシステムオブジェクト.GetFolder(このExcelが登録されているフォルダパス)

   フォルダ数 = 0

   Call フォルダ直下のファイル数を取得(フォルダパス)
   
   ThisWorkbook.Worksheets("Sheet1").Range("A11").Resize(フォルダ数, 2) = データ

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "nn分ss秒") & " でした。"

End Sub


Private Sub フォルダ直下のファイル数を取得(フォルダパス)

   フォルダ数 = フォルダ数 + 1

   データ(フォルダ数, 1) = フォルダパス '一列目にフォルダ・パスを格納
   データ(フォルダ数, 2) = ファイルシステムオブジェクト.GetFolder(フォルダパス).Files.Count
      
   Set フォルダ_オブジェクト = ファイルシステムオブジェクト.GetFolder(フォルダパス)

   For Each サブフォルダ In フォルダ_オブジェクト.SubFolders
      'フォルダ直下のすべてのフォルダを対象に
      Debug.Print サブフォルダ.Path
      'サブフォルダを使って、再帰呼び出しする
      Call フォルダ直下のファイル数を取得(サブフォルダ.Path)
   Next
   
End Sub