| |
▼すず さん：
こんばんは〜
>そして、新たに問題が2点出てきてしまいました。
>
>●問題点1
>こちらで質問させていただいた日報のブック名を確認
>したところ、日付の部分が単純に「101206」のようなyymmdd形式になって
>いるものと、「2010-12-06」のように「-」で区切られている2パターンがありました。
>●問題点2
>日報が保存されているフォルダが2つありました。
>たとえば、フォルダAには「101206」のつく日報があり、フォルダBには「2010-12-06」のつく日報があるという具合になります。
>その場合、mypathの部分をどのように変更すればよろしいでしょうか
まず
>●問題点2
のために、myPathに セミコロン(;)で区切って複数のパス名を
記入するように 変更してみてください。
↓
myPath = "\\サーバ名\フォルダ名\;\\サーバ名\フォルダ名2\" '◆要変更
>●問題点1
については、InputBoxでの入力は これまでどおり yymmdd 形式で
入れておいてください。たとえば 「101120」と入力しますと、
プログラムのほうで、
*101120*.xls
と
*2010-11-20*.xls
と2種類の検索ファイル名を作成します。
で、プログラム内で これらを組み合わせて 計4種類の検索パターンを
作成し、これをDIRコマンドのパラメータにしています。
こんな風にです↓
DIR "\\サーバ名\フォルダ名\*101120*.xls" _
"\\サーバ名\フォルダ名\*2010-11-20*.xls" _
"\\サーバ名\フォルダ名2\*101120*.xls" _
"\\サーバ名\フォルダ名2\*2010-11-20*.xls" _
/b/s > "C:\Users\kanabun\AppData\Local\Temp\Dir.tmp"
上記変更点について修正したものを以下に示しますので、
新規モジュールに 下記をコピペしてテストしてみてください。
'---------------------------------------------- 標準モジュール2
Option Explicit
Sub ファイル取得ボタン_Click()
Dim myPath As String
myPath = "\\サーバ名\フォルダ名\;\\サーバ名\フォルダ名2\" '◆要変更
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;*20" _
& Format$(Filename, "##-##-##") & "*.xls"
''検索パスとファイルパターンを指定してファイル検索
FoundFiles = GetFile(myPath, Filename)
If UBound(FoundFiles) < 0 Then
MsgBox "該当ファイルが見つかりません"
Exit Sub
End If
Dim WB0 As Workbook
Set WB0 = Workbooks("コピー先Book.xls")'あらかじめ開いておく◆要変更
Dim WB As Workbook
Dim ws As Worksheet
'--- ↓確認用
For i = 0 To UBound(FoundFiles) - 1
Debug.Print FoundFiles(i)
Next
'--- Open抽出 実行
For i = 0 To UBound(FoundFiles) - 1
Set WB = Workbooks.Open(FoundFiles(i))
For Each ws In WB.Worksheets
Select Case ws.Name
Case "東京", "大阪", "名古屋"
このシートより転記 ws, WB0
End Select
Next
WB.Close False
Set WB = Nothing
Next
Set WB0 = Nothing
MsgBox "転記終了!"
End Sub
Private Sub このシートより転記( _
ByVal ws As Worksheet, _
ByVal WB0 As Workbook)
Dim ws0 As Worksheet
Set ws0 = WB0.Worksheets(ws.Name)
Dim r As Range
With ws
Set r = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
Set r = r.Resize(r.Rows.Count - 1, 3)
End With
r.Copy ws0.Range("D1")
End Sub
'サブフォルダを含むファイルの検索（ファイルリストを返す）
Private Function GetFile(myPath As String, _
Filename As String) As String()
Dim myPaths, Filenames
Dim tmpPath As String
Dim sCmd As String
Dim i&, j&, ko As Long
tmpPath = Environ$("Temp") & "\Dir.tmp"
myPaths = Split(myPath, ";")
Filenames = Split(Filename, ";")
For i = 0 To UBound(myPaths)
If Right$(myPaths(i), 1) <> "\" Then
myPaths(i) = myPaths(i) & "\"
End If
For j = 0 To UBound(Filenames)
sCmd = sCmd & " """ & myPaths(i) & Filenames(j) & """ "
Next
Next
sCmd = "DIR " & sCmd & "/b/s > """ & tmpPath & """"
'Debug.Print sCmd
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 10/12/8(水) 4:11 -
