| |
転記元の何処の範囲を、転記先の何処の範囲に、どの様に転記するのか解らないので
取り合えず、指定したフォルダ以下で、指定した顧客番号を含む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して、転記していけば善いのでは？
|
|
Hirofumi
- 05/3/1(火) 20:57 -
