Excel VBA質問箱 IV

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

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


13471 / 13644 ツリー ←次へ | 前へ→

【5238】指定ディレクトリからファイルを探しコピー jam 03/4/30(水) 12:01 質問
【5241】「ある条件」って何? こう 03/4/30(水) 12:54 発言
【5245】Re:「ある条件」って何? jam 03/4/30(水) 13:36 回答
【5252】Re:「ある条件」って何? jam 03/4/30(水) 14:54 質問
【5256】Re:指定ディレクトリからファイルを探しコ... ポンタ 03/4/30(水) 16:04 回答
【5257】Re:指定ディレクトリからファイルを探しコ... jam 03/4/30(水) 16:20 質問
【5258】Re:指定ディレクトリからファイルを探しコ... ポンタ 03/4/30(水) 16:31 回答
【5260】Re:指定ディレクトリからファイルを探しコ... jam 03/4/30(水) 16:46 質問
【5262】Re:指定ディレクトリからファイルを探しコ... ポンタ 03/4/30(水) 17:58 回答
【5263】Re:指定ディレクトリからファイルを探しコ... jam 03/4/30(水) 19:15 お礼
【5259】別解 ichinose 03/4/30(水) 16:44 回答
【5264】Re:別解 jam 03/4/30(水) 19:18 お礼

【5238】指定ディレクトリからファイルを探しコピー
質問  jam  - 03/4/30(水) 12:01 -

引用なし
パスワード
    はじめまして、VBA初心者を脱しきれない
 jamと申します。
 
 皆様のお知恵を借りたいと思いまして、投稿しました。
 
 ある指定されたディレクトリから、ある条件でファイルを検索して
 合致したものを、別のフォルダにコピーするというものなのですが
 いまいちわかりません。
 皆様どうかお知恵をお貸しください。
 
 では。
 

【5241】「ある条件」って何?
発言  こう E-MAIL  - 03/4/30(水) 12:54 -

引用なし
パスワード
   jam さん,こんにちわ
> ある指定されたディレクトリから、ある条件でファイルを検索して
> 合致したものを、別のフォルダにコピーするというものなのですが

「ある条件」って何ですか?
ファイル名ならDOSコマンドでコピーできますが...

ファイル名称がAAで始まるファイルをC:\BETU\フォルダに複写
COPY AA*.* C:\BETU\

【5245】Re:「ある条件」って何?
回答  jam  - 03/4/30(水) 13:36 -

引用なし
パスワード
   こうさん はじめまして。

条件は、ファイル名です。

下のような、DOSコマンドをマクロで
できるのでしょうか?
マクロの仕様としては、ファイルを自動的に集めて
その中身を集計するといったようなものにしたいのです。
(DOSコマンドはよく知らないもんで…(−−;))

【5252】Re:「ある条件」って何?
質問  jam  - 03/4/30(水) 14:54 -

引用なし
パスワード
   こうさん はじめまして。
jamです。

条件は、ファイル名です。

下のような、DOSコマンドをマクロで
できるのでしょうか?
マクロの仕様としては、ファイルを自動的に集めて
その中身を集計するといったようなものにしたいのです。
(DOSコマンドはよく知らないもんで…(−−;))

【5256】Re:指定ディレクトリからファイルを探しコ...
回答  ポンタ  - 03/4/30(水) 16:04 -

引用なし
パスワード
   横から失礼します。
こういうことでしょうか?

Path1 のフォルダ内を調べて、
Path2 にコピーしています。

適切に書き換えてお試しください。

Sub test()
  Dim Path1 As String, Path2 As String
  Dim objFs As Object
  Dim objFolder As Object
  Dim objFile As Object
  '環境に合わせて書き直してください
  Path1 = "C:\My Documents\test1\"
  Path2 = "C:\My Documents\test2\"
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFs.GetFolder(Path1)
  For Each objFile In objFolder.Files
    If InStr(1, objFile.Name, "0") > 0 Then
      Call objFs.Copyfile(objFile.Path, Path2)
    End If
  Next
End Sub

【5257】Re:指定ディレクトリからファイルを探しコ...
質問  jam  - 03/4/30(水) 16:20 -

引用なし
パスワード
   ▼ポンタ さん

はじめまして jamと申します。
おかげさまで無事、動くようになりました。
ですが…。 もってくるファイルの条件を指定するところが
まだよくわからないのです…。 すいません まだまだ初心者なもんで…。
(--;)
もってくるファイルの例は、頭が”XXXX”の奴みたいな感じで
複数あります。
誠に申し訳ありませんが、ご教授願えると…。


>横から失礼します。
>こういうことでしょうか?
>
>Path1 のフォルダ内を調べて、
>Path2 にコピーしています。
>
>適切に書き換えてお試しください。
>
>Sub test()
>  Dim Path1 As String, Path2 As String
>  Dim objFs As Object
>  Dim objFolder As Object
>  Dim objFile As Object
>  '環境に合わせて書き直してください
>  Path1 = "C:\My Documents\test1\"
>  Path2 = "C:\My Documents\test2\"
>  Set objFs = CreateObject("Scripting.FileSystemObject")
>  Set objFolder = objFs.GetFolder(Path1)
>  For Each objFile In objFolder.Files
>    If InStr(1, objFile.Name, "0") > 0 Then
>      Call objFs.Copyfile(objFile.Path, Path2)
>    End If
>  Next
>End Sub

【5258】Re:指定ディレクトリからファイルを探しコ...
回答  ポンタ  - 03/4/30(水) 16:31 -

引用なし
パスワード
   If InStr(1, objFile.Name, "0") > 0 Then

↑の部分で「ファイル名に"0"を含んでいる」という条件を判定し、
条件を満たしていればコピーをしています。

> もってくるファイルの例は、頭が”XXXX”の奴みたいな感じで
> 複数あります。

ということなら、

If Left(objFile.Name, 4) = "XXXX" Then

に書き換えて、
「ファイル名の先頭4文字が"XXXX"に等しい」という条件を
満たしたときにコピーするようにすればよいと思います。

【5259】別解
回答  ichinose  - 03/4/30(水) 16:44 -

引用なし
パスワード
   ▼jam さん:
ポンタ さん、こうさん
こんにちは。

'====================================================
Sub test()
  Dim あるフォルダ As String
  Dim 別のフォルダ As String
  Dim コピー条件 As String
  あるフォルダ = "D:\My Documents\TESTエリア"
  別のフォルダ = "D:\My Documents\copytest"
  コピー条件 = "*.xls"
  MsgBox "フォルダ「" & _
    別のフォルダ & "」に " & sp_copy(あるフォルダ, 別のフォルダ, コピー条件) & "個のファイルをコピーしました"
End Sub
'===================================================================
Function sp_copy(あるフォルダ As String, 別のフォルダ As String, コピー条件 As String) As Long
  On Error GoTo err_sp_copy
  Dim flnm As String
  flnm = Dir(あるフォルダ & "\" & コピー条件)
  sp_copy = 0
  Do While flnm <> ""
   FileCopy あるフォルダ & "\" & flnm, 別のフォルダ & "\" & flnm
   sp_copy = sp_copy + 1
   flnm = Dir()
   Loop
ret_sp_copy:
  On Error GoTo 0
  Exit Function
err_sp_copy:
  MsgBox Error(Err.Number)
  Resume ret_sp_copy
End Function
でどうでしょう?

ちなみにDosコマンドだと、
'=============================================================
Sub test()
  Dim あるフォルダ As String
  Dim 別のフォルダ As String
  Dim コピー条件 As String
  あるフォルダ = "D:\My Documents\TESTエリア"
  別のフォルダ = "D:\My Documents\copytest"
  コピー条件 = "*.xls"
  Call copy_dos(あるフォルダ, 別のフォルダ, コピー条件)
End Sub
'======================================================================
Sub copy_dos(あるフォルダ As String, 別のフォルダ As String, コピー条件 As String)
   Shell Environ$("COMSPEC") & " /C copy """ & あるフォルダ & "\" & コピー条件 & """, """ & 別のフォルダ & "\*.*""", vbHide
End Sub

Dosコマンドって、VBAで初めて使いましたので、ちょっと心配ですが・・。
Shellだから、同期を取らなければならないときは、面倒かも・・・。
でも、処理は、最初のコードより、速かったですよ。

【5260】Re:指定ディレクトリからファイルを探しコ...
質問  jam  - 03/4/30(水) 16:46 -

引用なし
パスワード
   ポンタさん
 
 またまたありがとうございます。
 jamです。
 m(_ _)m

 対象のもののコピーはうまくいきました。
 が…。まだ問題がありました…。
 (--;)
 
 コピーする元のファイルのフォルダのなかに
 更にフォルダがあって、そのなかにファイルがあるパターンもあるのですが
 その場合が拾えないのです。(もちらん直下にある場合もあります)
 要するに、コピーする元のフォルダ内にある全てのファイル(フォルダ)
 のファイルを確認して対象をコピーしたいのです…。
 (コピーする元のフォルダのなかのフォルダ名は固定できません)
 
 まことに教えて君で、なさけない限りなのですが
 再びご教授ねがえると…。
 

【5262】Re:指定ディレクトリからファイルを探しコ...
回答  ポンタ  - 03/4/30(水) 17:58 -

引用なし
パスワード
   調べてみたら、ワイルドカードが使えるようなので、
以下のコードでも動きそうです。

Sub test()
  Dim Path1 As String, Path2 As String
  Dim objFs As Object
  Dim objFolder As Object
  '環境に合わせて書き直してください
  Path1 = "C:\My Documents\test1\"
  Path2 = "C:\My Documents\test2\"
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Call MyFileCopy(objFs.GetFolder(Path1), Path2)
End Sub

Sub MyFileCopy(objFolder As Object, Path As String)
  On Error Resume Next
  Dim objFs As Object
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Dim objFile As Object, objSubFolder As Object
  Call objFs.Copyfile(objFolder.Path & "\××××*", Path)
  For Each objSubFolder In objFolder.SubFolders
    Call MyFileCopy(objSubFolder, Path)
  Next
End Sub

ただ、同名のファイルが存在した場合を考慮すると、
以下のようにした方がよいかもしれません。

Sub test()
  Dim Path1 As String, Path2 As String
  Dim objFs As Object
  Dim objFolder As Object
  '環境に合わせて書き直してください
  Path1 = "C:\My Documents\test1\"
  Path2 = "C:\My Documents\test2\"
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Call MyFileCopy(objFs.GetFolder(Path1), Path2)
End Sub

Sub MyFileCopy(objFolder As Object, Path As String)
  On Error Resume Next
  Dim objFs As Object
  Dim objFile As Object, objSubFolder As Object
  Dim Mes As String
  Set objFs = CreateObject("Scripting.FileSystemObject")
  For Each objFile In objFolder.Files
    If Left(objFile.Name, 4) = "××××" Then
      If objFs.FileExists(Path & objFile.Name) Then
        Mes = Path & objFile.Name & "はすでに存在します" & vbCr & "上書きしますか?"
        If MsgBox(Mes, vbYesNo) = vbYes Then
          Call objFs.Copyfile(objFolder.Path & "\××××*", Path)
        End If
      Else
        Call objFs.Copyfile(objFolder.Path & "\××××*", Path)
      End If
    End If
  Next
  For Each objSubFolder In objFolder.SubFolders
    Call MyFileCopy(objSubFolder, Path)
  Next
End Sub

【5263】Re:指定ディレクトリからファイルを探しコ...
お礼  jam  - 03/4/30(水) 19:15 -

引用なし
パスワード
   ポンタさん。
わざわざ、調べてもらったなんて…。
そのかいあってかというのか、うまくいきました。
いろいろお手数おかけしました。
少しでもポンタさんにちかづけるようがんばりたいと思います。
いったいいつになることやら…(^^;)

 jam

【5264】Re:別解
お礼  jam  - 03/4/30(水) 19:18 -

引用なし
パスワード
   ichinose さん

はじめまして、jamです。
わざわざ回答ありがとうございました。
(上記の、ポンタさんのものでなんとか完成しました)

しかし、なにか難しそうですね…(^^;)
皆様にちかづけるよう日々努力せねば…

お手数おかけしました。 では。

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