標題: [發問] 搜尋複製問題 [打印本頁]

---

作者: imzues    時間: 2012-3-16 13:37     標題: 搜尋複製問題

本帖最後由 imzues 於 2012-3-16 17:23 編輯

請問各位大大VBA有辦法可以
將EXCLE裡的檔名，搜尋路徑中的資料夾，複製到某個資料夾嗎？

---

作者: mark15jill    時間: 2012-3-16 14:40

回復 1# imzues
版上有類似文章..
這是基礎用法. 可以視情況加以應用

    Sub ox()
    Set fd = CreateObject("scripting.filesystemobject")
        fd.copyfolder "d:\9996\995", "d:\9996\996\993\"  '995 資料夾 整份複製到 993 內
End Sub

---

作者: imzues    時間: 2012-3-19 09:54

回復 2# mark15jill

我附件上來，想請大大幫忙解決
感謝
[attach]10047[/attach]

---

作者: Hsieh    時間: 2012-3-19 10:29

回復 3# imzues

1. Sub ex()
   
2. Set fdo = CreateObject("Scripting.FileSystemObject")
   
3. fd = "D:\A\"
   
4. fs = Dir(fd & "*")
   
5. Do Until fs = ""
   
6.    If IsNumeric(Application.Match(Split(fs, "-")(0), Columns("A"), 0)) Then
   
7.    fdo.copyfile fd & fs, "D:\B\" & fs
   
8.    End If
   
9.    fs = Dir
   
10. Loop
    
11. End Sub

複製代碼

---

作者: hugh0620    時間: 2012-3-19 10:35

本帖最後由 hugh0620 於 2012-3-19 10:36 編輯

回復 3# imzues


    我的寫法跟H大大不太一樣
    是比較屬於浮動的路徑~ 提供給你參考~

1. Private Sub CommandButton1_Click()
   
2. '===== 選擇存的路徑=======
   
3. With Application.FileDialog(msoFileDialogFolderPicker)
   
4.     If .Show = 0 Then Exit Sub
   
5.     patch = .SelectedItems(1)
   
6.     Application.DefaultFilePath = patch
   
7. End With
   
8. '=====================
   
9. '=====檔案要比對的路徑======
   
10. With Application.FileDialog(msoFileDialogFolderPicker)
    
11.     If .Show = 0 Then Exit Sub
    
12.     fd = .SelectedItems(1)
    
13.     If .ButtonName = "確定" Then
    
14.     fs = Dir(fd & "\*.xls")
    
15.         Do Until fs = ""
    
16.            sa = Left(fs, 9)
    
17.            Set fk = Sheet1.Range("A:A").Find(sa)
    
18.            If Not fk Is Nothing Then
    
19.             With Workbooks.Open(fs)
    
20.             .SaveAs Application.DefaultFilePath & "\" & fs
    
21.             .Close
    
22.             End With
    
23.            End If
    
24.            fs = Dir
    
25.         Loop
    
26.     End If
    
27. End With
    
28. '=============================
    
29. End Sub

複製代碼

---

作者: mark15jill    時間: 2012-3-19 10:46

回復 3# imzues
預設  D:\A資料夾   D:\B資料夾
動作： 從EXCEL 判斷檔名 再從A 複製到 B  (搬移會有問題)

Sub test()

    Dim objFs As Object
    Set objFs = CreateObject("Scripting.FileSystemObject")
For xt = 1 To 20
    If Range("a" & xt).Value <> "" Then
            For xuo = 1 To 20
                If Dir("d:\比對\A資料夾\" & Left(Range("a" & xt).Value, 9)) & "-051115619000-OEM-T 190.xls" <> "" Then
                        objFs.copyfile "d:\比對\A資料夾\" & Left(Range("a" & xt).Value, 9) & "*.xlsx", "D:\比對\B資料夾\"
                End If
            
            Next xuo
    End If
Next xt
   'Set objFs = Nothing
End Sub


   

[attach]10048[/attach]

---

作者: imzues    時間: 2012-3-19 14:34

感謝各位大大，學到很多
我的問題解決了!!!

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)