imzues

帖子: 72
主題: 24
精華: 0
積分: 172
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-7-16
最後登錄: 2023-7-6

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2012-3-16 13:37 | 只看該作者

[發問] 搜尋複製問題

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

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

樓主熱帖

imzues

中學生 Rank: 2

帖子: 72
主題: 24
精華: 0
積分: 172
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-7-16
最後登錄: 2023-7-6

7^#

發表於 2012-3-19 14:34 | 只看該作者

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

TOP

mark15jill

　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生 Rank: 3 Rank: 3

帖子: 852
主題: 79
精華: 0
積分: 918
點名: 0
作業系統: Windows 7 , XP
軟體版本: Office 2007, Office 2003,Office 2010,YoZo Office
閱讀權限: 50
性別: 男
來自: 宇宙
註冊時間: 2011-4-8
最後登錄: 2024-2-21

6^#

發表於 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

text.rar (40.35 KB)

TOP

hugh0620

　暱稱: VBA向前衝

高中生 Rank: 3 Rank: 3

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

5^#

發表於 2012-3-19 10:35 | 只看該作者

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

回復 3# imzues

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

Private Sub CommandButton1_Click()
'===== 選擇存的路徑=======
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then Exit Sub
patch = .SelectedItems(1)
Application.DefaultFilePath = patch
End With
'=====================
'=====檔案要比對的路徑======
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then Exit Sub
fd = .SelectedItems(1)
If .ButtonName = "確定" Then
fs = Dir(fd & "\*.xls")
Do Until fs = ""
sa = Left(fs, 9)
Set fk = Sheet1.Range("A:A").Find(sa)
If Not fk Is Nothing Then
With Workbooks.Open(fs)
.SaveAs Application.DefaultFilePath & "\" & fs
.Close
End With
End If
fs = Dir
Loop
End If
End With
'=============================
End Sub

複製代碼

學習才能提升自己

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 278
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-24

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2012-3-19 10:29 | 只看該作者

回復 3# imzues

Sub ex()
Set fdo = CreateObject("Scripting.FileSystemObject")
fd = "D:\A\"
fs = Dir(fd & "*")
Do Until fs = ""
If IsNumeric(Application.Match(Split(fs, "-")(0), Columns("A"), 0)) Then
fdo.copyfile fd & fs, "D:\B\" & fs
End If
fs = Dir
Loop
End Sub

複製代碼

學海無涯_不恥下問

TOP

imzues

中學生 Rank: 2

帖子: 72
主題: 24
精華: 0
積分: 172
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-7-16
最後登錄: 2023-7-6

3^#

發表於 2012-3-19 09:54 | 只看該作者

回復 2# mark15jill

我附件上來，想請大大幫忙解決
感謝

text.zip (4.22 KB)

TOP

mark15jill

　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生 Rank: 3 Rank: 3

帖子: 852
主題: 79
精華: 0
積分: 918
點名: 0
作業系統: Windows 7 , XP
軟體版本: Office 2007, Office 2003,Office 2010,YoZo Office
閱讀權限: 50
性別: 男
來自: 宇宙
註冊時間: 2011-4-8
最後登錄: 2024-2-21

2^#

發表於 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

TOP