Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
13473 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【5238】指定ディレクトリからファイルを探しコピー ｊａｍ 03/4/30(水) 12:01 質問
【5241】「ある条件」って何？ こう 03/4/30(水) 12:54 発言
【5245】Re:「ある条件」って何？ ｊａｍ 03/4/30(水) 13:36 回答
【5252】Re:「ある条件」って何？ ｊａｍ 03/4/30(水) 14:54 質問
【5256】Re:指定ディレクトリからファイルを探しコ... ポンタ 03/4/30(水) 16:04 回答
【5257】Re:指定ディレクトリからファイルを探しコ... ｊａｍ 03/4/30(水) 16:20 質問
【5258】Re:指定ディレクトリからファイルを探しコ... ポンタ 03/4/30(水) 16:31 回答
【5260】Re:指定ディレクトリからファイルを探しコ... ｊａｍ 03/4/30(水) 16:46 質問
【5262】Re:指定ディレクトリからファイルを探しコ... ポンタ 03/4/30(水) 17:58 回答
【5263】Re:指定ディレクトリからファイルを探しコ... ｊａｍ 03/4/30(水) 19:15 お礼
【5259】別解 ichinose 03/4/30(水) 16:44 回答
【5264】Re:別解 ｊａｍ 03/4/30(水) 19:18 お礼
【5238】指定ディレクトリからファイルを探しコピー
質問  ｊａｍ  - 03/4/30(水) 12:01 -
引用なし
パスワード
   　はじめまして、ＶＢＡ初心者を脱しきれない
　ｊａｍと申します。
　
　皆様のお知恵を借りたいと思いまして、投稿しました。
　
　ある指定されたディレクトリから、ある条件でファイルを検索して
　合致したものを、別のフォルダにコピーするというものなのですが
　いまいちわかりません。
　皆様どうかお知恵をお貸しください。
　
　では。
　
【5241】「ある条件」って何？
発言  こう E-MAIL  - 03/4/30(水) 12:54 -
引用なし
パスワード
   ｊａｍ さん，こんにちわ
>　ある指定されたディレクトリから、ある条件でファイルを検索して
>　合致したものを、別のフォルダにコピーするというものなのですが

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

ファイル名称がAAで始まるファイルをC:\BETU\フォルダに複写
COPY AA*.* C:\BETU\
【5245】Re:「ある条件」って何？
回答  ｊａｍ  - 03/4/30(水) 13:36 -
引用なし
パスワード
   こうさん　はじめまして。

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

下のような、ＤＯＳコマンドをマクロで
できるのでしょうか？
マクロの仕様としては、ファイルを自動的に集めて
その中身を集計するといったようなものにしたいのです。
（ＤＯＳコマンドはよく知らないもんで…(−−；))
【5252】Re:「ある条件」って何？
質問  ｊａｍ  - 03/4/30(水) 14:54 -
引用なし
パスワード
   こうさん　はじめまして。
ｊａｍです。

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

下のような、ＤＯＳコマンドをマクロで
できるのでしょうか？
マクロの仕様としては、ファイルを自動的に集めて
その中身を集計するといったようなものにしたいのです。
（ＤＯＳコマンドはよく知らないもんで…(−−；))
【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:指定ディレクトリからファイルを探しコ...
質問  ｊａｍ  - 03/4/30(水) 16:20 -
引用なし
パスワード
   ▼ポンタ さん

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


>横から失礼します。
>こういうことでしょうか？
>
>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"を含んでいる」という条件を判定し、
条件を満たしていればコピーをしています。

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

ということなら、

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

に書き換えて、
「ファイル名の先頭4文字が"ＸＸＸＸ"に等しい」という条件を
満たしたときにコピーするようにすればよいと思います。
【5259】別解
回答  ichinose  - 03/4/30(水) 16:44 -
引用なし
パスワード
   ▼ｊａｍ さん：
ポンタ さん、こうさん
こんにちは。

'====================================================
Sub test()
　　Dim あるフォルダ As String
　　Dim 別のフォルダ As String
　　Dim コピー条件 As String
　　あるフォルダ = "D:\My Documents\ＴＥＳＴエリア"
　　別のフォルダ = "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\ＴＥＳＴエリア"
　　別のフォルダ = "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:指定ディレクトリからファイルを探しコ...
質問  ｊａｍ  - 03/4/30(水) 16:46 -
引用なし
パスワード
   ポンタさん
　
　またまたありがとうございます。
　ｊａｍです。
　ｍ(_　_)ｍ

　対象のもののコピーはうまくいきました。
　が…。まだ問題がありました…。
　(--;)
　
　コピーする元のファイルのフォルダのなかに
　更にフォルダがあって、そのなかにファイルがあるパターンもあるのですが
　その場合が拾えないのです。（もちらん直下にある場合もあります）
　要するに、コピーする元のフォルダ内にある全てのファイル(フォルダ）
　のファイルを確認して対象をコピーしたいのです…。
　（コピーする元のフォルダのなかのフォルダ名は固定できません）
　
　まことに教えて君で、なさけない限りなのですが
　再びご教授ねがえると…。
　
【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:指定ディレクトリからファイルを探しコ...
お礼  ｊａｍ  - 03/4/30(水) 19:15 -
引用なし
パスワード
   ポンタさん。
わざわざ、調べてもらったなんて…。
そのかいあってかというのか、うまくいきました。
いろいろお手数おかけしました。
少しでもポンタさんにちかづけるようがんばりたいと思います。
いったいいつになることやら…(^^;)

　jam
【5264】Re:別解
お礼  ｊａｍ  - 03/4/30(水) 19:18 -
引用なし
パスワード
   ichinose さん

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

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

お手数おかけしました。　では。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
13473 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free