コピー＆ペーストするには？ (ID:101549)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

書き込み内容、態度に疑問もありますが下記の様なものでは如何？
適宜自分の環境、仕様に合わせて修正して下さい。

下記の  VBレスキュー(花ちゃん)  さんのホームページの
VB6.0関係  カテゴリ別一覧  FileSystemObject  の中の
指定のファイルをコピー・削除・移動する  
ドライブ名・ファイル名・Folderオブジェクト・パス等の取得  
指定フォルダー以下(サブフォルダー内を含む)の全ファイルを列挙する
．．．などを参考にさせて頂きました。  （感謝）

http://hanatyan.sakura.ne.jp/

Option Explicit

Dim Fso As New FileSystemObject
Dim Cpname As String
Dim Psname As String
Dim Schname As String

Private Sub Command1_Click()
    
    Cpname = "C:\tmp1"   '"コピー元の親フォルダ" '
    Psname = "C:\tmp4"   '"コピー先のフォルダ" '
    Schname = "BU_2.xls" 'コピーしたいファイル
    
    '指定のフォルダを指定
    Call sFolderSearch2(Fso.GetFolder(Cpname))
    Set Fso = Nothing

End Sub

Private Sub sFolderSearch2(ByVal myFolder As Object)
    Dim mySubFolder As Folder
    Dim myFile      As File
    Dim v As Integer
    Dim i As Integer
    Dim tmp As String
    Dim dat() As String
    
    '現在のフォルダ内のファイルを取得
    For Each myFile In myFolder.Files
        '指定の拡張子のファイルを取得する場合
        If myFile.Name = Schname Then
            dat = Split(myFolder & "\" & myFile.Name, "\")
            tmp = Cpname
            tmp = Replace(tmp, ":\", "_")
            
            For i = 2 To UBound(dat) - 1
                tmp = tmp & "_" & dat(i)
            Next i
            
            Fso.GetFile(myFolder & "\" & myFile.Name).Copy Psname & "\" & tmp & "_" & myFile.Name
        
        End If
    Next
    
    With myFolder
        'サブフォルダ数を取得
        If .SubFolders.Count > 0 Then
            For Each mySubFolder In .SubFolders
                'サブフォルダがある場合再帰的に繰り返す
                Call sFolderSearch2(mySubFolder)
            Next
        End If
    End With

Set myFile = Nothing
    Set mySubFolder = Nothing

End Sub

←解決時は質問者本人がここをチェックしてください。

戻る