| |
>あるセルの値と同じ名前の図面ファイルがCドライブ、又は
>ネットワーク経由のフォルダにあります。
>その値と同じファイル名のファイルを検索して
>コピーして、名前を変えて新しいフォルダにはりつけます。
>”そしてその結果を、テキストファイルに
>「元のファイル名→新しいファイル名」
>といった感じで、貼り付けたフォルダに残したいのです”
1 検索するファイル名は、マクロ実行ブックのSheet1のA2以下に入力されている。
2 ネットワーク上のフォルダーのパスは、定数 CpFol で宣言。
3 コピー先フォルダーは、通常ブックを保存しているフォルダー
4 コピー後のファイル名は、元のファイル名の先頭に番号を付ける。
5 コピーしたファイルのリストを書いたテキストは、CpyLog.txt とする。
Sub MyFile_Copy()
Dim i As Long
Dim MyR As Range, C As Range
Dim PsFol As String, MyF As String
Dim Mylog As String, NewF As String
Const CpFol As String = _
"\\Computername\c\My Documents\"
'↑実際の保存先フォルダーのパスに変更する
PsFol = Application.DefaultFilePath & "\"
Mylog = PsFol & "CpyLog_" & Format(Date, "yymmdd") & ".txt"
With Worksheets("Sheet1")
If .Range("A65536").End(xlUp).Row = 1 Then
MsgBox "ブック名の入力がありません", 48: Exit Sub
End If
Set MyR = .Range("A2", .Range("A65536").End(xlUp))
End With
If Dir(Mylog) <> "" Then Kill Mylog
Open Mylog For Output Access Write As #1
For Each C In MyR
If LCase(Right$(C.Value, 4)) <> ".xls" Then GoTo NLine
MyF = "C:\" & C.Value
If Dir(MyF) = "" Then
MyF = CpFol & C.Value
If Dir(MyF) = "" Then
Print #1, C.Value & " : NotFound"
GoTo NLine
End If
End If
i = i + 1
NewF = Left$(C.Value, Len(C.Value) - 4) & "_" & i & ".xls"
FileCopy MyF, PsFol & NewF
Print #1, C.Value & " : " & NewF
NLine:
Next
Close #1: Set MyR = Nothing
MsgBox "ファイルコピーとログの作成を終了", 64
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
