| |
▼すず さん：
>・日付（yymmdd形式）がついた、微妙に名前の違う日報がいくつかあり、ネットワークドライブのフォルダにある。
>＜やりたいこと＞
>・コマンドボタンなどをクリックすると、メッセージボックスが表示され、作成する日をyymmdd形式で入力するだけで、入力したのと同じ日付の日報から該当データをとりまとめ用のファイルにコピーしたい。
>せめてヒントだけでもいただければと思います。
手始めに ネットワークから 指定のyymmddを含むxlsファイルの一覧を
取得する処理をコード化してみてはいかがでしょうか？
シート上に図形描画ツールボックスから適当なオートシェイプ
（「額縁」がおすすめ）を貼りつけて、名前を「ファイル取得ボタン」
に変更し、以下を標準モジュールにコピペして実験してみてください。
'(注) myPath はそちらの環境にあわせておいて、かつ実行する前に
' あらかじめ接続しておいてください。
'------------------------------------ 標準モジュール
Option Explicit
Sub ファイル取得ボタン_Click()
Dim myPath As String: myPath = "\\サーバ名\フォルダ名\" '◆要変更
Dim FileName As String
Dim i As Long
Dim FoundFiles() As String
FileName = InputBox$("yymmdd形式でファイル名を指定", "ファイルの取得")
If StrPtr(FileName) = 0& Then Exit Sub
If Not (FileName Like "######") Then Exit Sub
FileName = "*" & FileName & "*.xls"
''検索パスとファイルパターンを指定してファイル検索
FoundFiles = GetFile(myPath, FileName)
For i = 0 To UBound(FoundFiles)
Debug.Print FoundFiles(i)
Next
End Sub
'サブフォルダを含むファイルの検索（ファイルリストを返す）
Private Function GetFile(myPath As String, _
FileName As String) As String()
Dim tmpPath As String
Dim sCmd As String
Dim ko As Long
If Right$(myPath, 1) <> "\" Then myPath = myPath & "\"
tmpPath = Environ$("Temp") & "\Dir.tmp"
sCmd = "DIR """ & myPath & FileName & """ /b/s /o:N > """ _
& tmpPath & """"
With CreateObject("WScript.Shell")
ko = .Run("CMD /C " & sCmd, 7, True) 'Dirコマンド実行
End With
Dim io As Integer
Dim buf() As Byte
io = FreeFile()
Open tmpPath For Binary As io '出力ファイルリスト取得
ReDim buf(1 To LOF(io))
Get #io, , buf
Close io
Kill tmpPath
GetFile = Split(StrConv(buf, vbUnicode), vbCrLf)
End Function
'--------------------------------------------------
上は
Dir検索結果得られたフィル名リストをイミディエイト・
ウィンドウに表示しているだけですが､
> Debug.Print FoundFiles(i)
ここを
Set Wb = Workbooks.Open(FoundFiles(i))
'開いたファイルに対する転記処理 〜〜〜 〜〜〜
Wb.Close SaveChanges:=False
Set Wb = Nothing
のように､選択ファイルの転記処理に修正補間していくと
目的の処理ができるようになると思います。
|
|
kanabun
- 10/12/7(火) 10:28 -
