Excel VBA質問箱 IV

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

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


58721 / 76732 ←次へ | 前へ→

【22734】Re:複数フォルダー・ファイルからのデータ抽出
発言  Hirofumi  - 05/3/1(火) 20:57 -

引用なし
パスワード
   転記元の何処の範囲を、転記先の何処の範囲に、どの様に転記するのか解らないので
取り合えず、指定したフォルダ以下で、指定した顧客番号を含むBook名を取得する
コードをUpします

ただ、Dir関数なので上手くいくか?です
以下を、標準モジュールに記述して下さい

Option Explicit

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

Public Sub Test()

  Dim i As Long
  Dim vntFileName As Variant
  Dim strFolder As String
  Dim strCustomer As String
  
  '顧客番号を取得
  strCustomer = InputBox("顧客番号を12桁で入力して下さい", "顧客番号入力")
  If strCustomer = "" Then
    Exit Sub
  End If
  strCustomer = "*" & strCustomer & "*.xls"
  
  '四半期のフォルダを取得
  strFolder = GetFolderPath
  
  '四半期のフォルダ以下に有る、顧客番号を含むBookを取得
  vntFileName = FilesList(strFolder, strCustomer, True)
  
  '"Sheet1"にBook名を列挙
  With Worksheets("Sheet1")
    If vntFileName(0) <> "" Then
      For i = 0 To UBound(vntFileName)
        .Cells(i + 1, 1).Value = vntFileName(i)
      Next i
    Else
      Beep
      MsgBox "該当するBookが有りません"
    End If
  End With
  
End Sub

Public Function FilesList(ByVal strFilesPath As String, _
              ByVal strSearchFile As String, _
              Optional blnSubDir As Boolean = False) As Variant

  Dim strData() As String
  
  ReDim strData(0)
  ChooseFiles strFilesPath, strSearchFile, strData(), blnSubDir
  
  FilesList = strData()
  
End Function

Private Sub ChooseFiles(ByVal strFilesPath As String, _
            ByVal strSearchFile As String, _
            strData() As String, _
            blnSubDir As Boolean)

  Dim i As Long
  Dim j As Long
  Dim strFileName As String
  Dim strDirList() As String

  '結果用配列の書き込み位置を取得
  If strData(UBound(strData)) = "" Then
    i = UBound(strData)
  Else
    i = UBound(strData) + 1
  End If
  'パスの最後に\を付加
  If Right(strFilesPath, 1) <> "\" Then
    strFilesPath = strFilesPath & "\"
  End If
  
  'ディレクトリ内の全ての標準ファイルを列挙
  strFileName = Dir(strFilesPath & strSearchFile)
  Do Until strFileName = ""
    ReDim Preserve strData(i)
    strData(i) = strFilesPath & strFileName
    i = i + 1
    strFileName = Dir
  Loop

  If blnSubDir Then
    'サブディレクトリの一時的なリストを作成
    strFileName = Dir(strFilesPath, vbDirectory)
    Do Until strFileName = ""
      '現在のディレクトリと親ディレクトリを無視
      If strFileName <> "." And strFileName <> ".." Then
        'ディレクトリ以外を無視
        If GetAttr(strFilesPath & strFileName) _
                      And vbDirectory Then
          j = j + 1
          ReDim Preserve strDirList(j)
          strDirList(j) = strFilesPath & strFileName
        End If
      End If
      strFileName = Dir
    Loop
    '各ディレクトリを再帰処理
    For i = 1 To j
      ChooseFiles strDirList(i), strSearchFile, strData(), True
    Next i
  End If
  
End Sub

Private 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

此れにより、「Sub Test」の中のvntFileName変数に該当するBook名が取得されますので
これをLoopして、転記していけば善いのでは?
0 hits

【22720】複数フォルダー・ファイルからのデータ抽出 MAYUMI 05/3/1(火) 9:51 質問
【22724】Re:複数フォルダー・ファイルからのデータ... IROC 05/3/1(火) 10:26 回答
【22728】Re:複数フォルダー・ファイルからのデータ... kazu 05/3/1(火) 13:09 発言
【22730】Re:複数フォルダー・ファイルからのデータ... MAYUMI 05/3/1(火) 15:15 発言
【22734】Re:複数フォルダー・ファイルからのデータ... Hirofumi 05/3/1(火) 20:57 発言
【22735】Re:複数フォルダー・ファイルからのデータ... Hirofumi 05/3/1(火) 21:00 発言
【22736】Re:複数フォルダー・ファイルからのデータ... Hirofumi 05/3/1(火) 21:33 発言
【22739】Re:複数フォルダー・ファイルからのデータ... kazu 05/3/1(火) 22:40 発言
【22751】Re:複数フォルダー・ファイルからのデータ... ichinose 05/3/2(水) 11:18 発言
【22752】Re:複数フォルダー・ファイルからのデータ... MAYUMI 05/3/2(水) 11:44 質問
【22753】Re:複数フォルダー・ファイルからのデータ... kazu 05/3/2(水) 12:49 発言
【22781】Re:複数フォルダー・ファイルからのデータ... MAYUMI 05/3/3(木) 9:45 お礼

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