FileCopy 同名檔案不覆蓋 - Excel程式區

[發問] FileCopy 同名檔案不覆蓋

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2014-9-11 16:28 | 顯示全部帖子

回復 1# li_hsien
試試看

Option Explicit
Sub SF_collection_Click()
Dim 目的目錄 As String, 搜尋目錄 As String, T As Date, Fs As Object, Sf As Object, f As Object
Dim i As Integer, 檔名 As String, 副檔名 As String, 檔名_計數 As Integer, MyDir As String
目的目錄 = "D:\"
搜尋目錄 = "C:\test"
T = Time
Set Fs = CreateObject("Scripting.FileSystemObject")
Set Sf = Fs.GetFolder(搜尋目錄).SubFolders
For Each f In Sf
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = f '傳回大寫的資料夾名稱
.Filename = "*.*"
.Execute
For i = 1 To .FoundFiles.Count
檔名 = Fs.GetBaseName(.FoundFiles(i))
副檔名 = Fs.GetExtensionName(.FoundFiles(i))
檔名_計數 = 0
MyDir = Dir(目的目錄 & 檔名 & "*." & 副檔名, vbDirectory)
Do While MyDir <> ""
檔名_計數 = 檔名_計數 + 1
MyDir = Dir
Loop
If 檔名_計數 > 0 Then
檔名 = 目的目錄 & 檔名 & "(" & 檔名_計數 & ")." & 副檔名
Else
檔名 = 目的目錄 & 檔名 & "." & 副檔名
End If
FileCopy .FoundFiles(i), 檔名
Next
End With
Next
Debug.Print "經過時間: " & DateDiff("n", T, Time) & "分"
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 為人處世要小心細心，但不要「小心眼」。