Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


57238 / 76732 ←次へ | 前へ→

【24231】Re:ファイル一覧作成
回答  Hirofumi  - 05/4/16(土) 12:20 -

引用なし
パスワード
   つづき
以下を標準モジュールに記述して下さい

Option Explicit

' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Public Function GetFolderPath() As String

  Dim strTitle As String
  Dim objFolder As Object
  Dim hWnd As Long
  Dim strTmpPath As String
  Const BIF_RETURNONLYFSDIRS = &H1
  Const ssfDESKTOP = &H0
  Const CSIDL_WINDOWS = &H24
  
  'アクティブなWindowのハンドルを取得
  hWnd = GetForegroundWindow
  ' 表示タイトルを指定
  strTitle = "フォルダを選択して下さい"
  ' フォルダ選択ダイアログを表示
  Set objFolder = CreateObject("Shell.Application"). _
              BrowseForFolder(hWnd, strTitle, _
                BIF_RETURNONLYFSDIRS, CSIDL_WINDOWS)
  ' フォルダを選択したときは
  If Not (objFolder Is Nothing) Then
    ' 選択フォルダを表示
    With objFolder
      ' 親フォルダが存在するときは
      If Not (.ParentFolder Is Nothing) Then
        ' 選択フォルダのフルパスを表示
        strTmpPath = .Items.Item.Path
      ' 親フォルダのときは
      Else
        ' フォルダ名を表示
        strTmpPath = .Title
      End If
    End With
    ' Folderオブジェクトを破棄
    Set objFolder = Nothing
  End If
  
  If strTmpPath <> "" And Right(strTmpPath, 1) <> "\" Then
    strTmpPath = strTmpPath & "\"
  End If

  GetFolderPath = strTmpPath
  
End Function

Public Function FilesList(ByVal strFolderPath As String, _
            ByVal strSearchFile As String, _
            Optional lngSubDir As Long = -1) As Variant

  Dim i As Long
  Dim j As Long
  Dim strFolders() As String
  Dim strFILENAME As String
  Dim strFileNames() As String
  
  'パスの最後に\を付加
  If Right(strFolderPath, 1) <> "\" Then
    strFolderPath = strFolderPath & "\"
  End If
    
  'フォルダのListを作成
  ReDim strFolders(0)
  '探し始めるフォルダを代入
  strFolders(0) = strFolderPath
  'フォルダをリストアップ
  If lngSubDir <> 0 Then
    GetFolders strFolderPath, strFolders(), _
            UBound(strFolders) + 1, lngSubDir
  End If
  
  j = 0
  ReDim strFileNames(1, j)
  For i = 0 To UBound(strFolders)
    'ディレクトリ内の全ての標準ファイルを列挙
    strFILENAME = Dir(strFolders(i) & strSearchFile)
    Do Until strFILENAME = ""
      ReDim Preserve strFileNames(1, j)
      strFileNames(0, j) = strFolders(i)
      strFileNames(1, j) = strFILENAME
      j = j + 1
      strFILENAME = Dir
    Loop
  Next i
    
  FilesList = strFileNames()
  
End Function

Public Function FoldersList(ByVal strFolderPath As String, _
            Optional lngSubDir As Long = -1) As Variant

'  strFolderPath:  探し始めるフォルダ名
'  lngSubDir:   探す階層数

  Dim strFolders() As String

  'パスの最後に\を付加
  If Right(strFolderPath, 1) <> "\" Then
    strFolderPath = strFolderPath & "\"
  End If

  ReDim strFolders(0)
  '探し始めるフォルダを代入
  strFolders(0) = strFolderPath
  'フォルダをリストアップ
  If lngSubDir <> 0 Then
    GetFolders strFolderPath, strFolders(), _
            UBound(strFolders) + 1, lngSubDir
  End If

  FoldersList = strFolders()

End Function

Private Sub GetFolders(ByVal strFilesPath As String, _
              strDirList() As String, _
              lngNextData As Long, _
              lngSubDir As Long)

  Dim i As Long
  Dim j As Long
  Dim lngNow As Long
  Dim strFILENAME As String

  '結果用配列の書き込み位置を取得
  i = lngNextData
  
  'サブディレクトリの結果リストと、一時的なリストを作成
  strFILENAME = Dir(strFilesPath, vbDirectory)
  Do Until strFILENAME = ""
    '現在のディレクトリと親ディレクトリを無視
    If strFILENAME <> "." And strFILENAME <> ".." Then
      'ディレクトリ以外を無視
      If GetAttr(strFilesPath & strFILENAME) _
                    And vbDirectory Then
        ReDim Preserve strDirList(i)
        '結果リストに追加
        strDirList(i) = strFilesPath & strFILENAME & "\"
        i = i + 1
      End If
    End If
    strFILENAME = Dir
  Loop
  
  j = lngNextData
  lngNextData = i
  'ディレクトリの階層を一つ下げる
  lngSubDir = lngSubDir - 1
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '各ディレクトリを再帰的に処理
    For i = j To lngNextData - 1
      lngNow = lngSubDir
      GetFolders strDirList(i), strDirList(), _
                      lngNextData, lngNow
    Next i
  End If

End Sub

Public Sub DeleteRows(rngTop As Range)

  Dim lngDelEnd As Long
  Dim lngDelTop As Long
  
  With rngTop
    lngDelEnd = .Offset(65536 - .Row, 6).End(xlUp).Row - .Row
    If lngDelEnd < 1 Then
      Exit Sub
    End If
  End With
  
  lngDelTop = 1
  With rngTop
    Range(.Offset(lngDelTop), .Offset(lngDelEnd)).EntireRow.Delete
  End With
    
End Sub

Public Sub DataSheetSort(rngTop As Range)

  With rngTop.CurrentRegion
    .Sort Key1:=.Item(1, 7), Order1:=xlAscending, _
        Key2:=.Item(1, 6), Order2:=xlAscending, _
        Key3:=.Item(1, 1), Order2:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin
  End With

End Sub

Public Sub BookOpen(ByVal strTarget As String)

  If Dir(strTarget) <> "" Then
    Workbooks.Open (strTarget)
  End If
  
End Sub

Public Sub IndeFormShow()

  ActiveCell.Activate
  
  UserForm1.Show
  
End Sub

以下をThisWorkBookのコードモジュールに記述して下さい

Private Sub Workbook_Open()

  IndeFormShow
  
End Sub
0 hits

【24228】ファイル一覧作成 あいんすと 05/4/16(土) 10:55 質問
【24229】Re:ファイル一覧作成 IROC 05/4/16(土) 11:35 回答
【24230】Re:ファイル一覧作成 Hirofumi 05/4/16(土) 12:18 回答
【24231】Re:ファイル一覧作成 Hirofumi 05/4/16(土) 12:20 回答
【24248】Re:ファイル一覧作成 Hirofumi 05/4/17(日) 9:06 回答
【24249】Re:ファイル一覧作成 あいんすと 05/4/17(日) 11:48 お礼

57238 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free