請問如何在"文字方塊"輸入條件後再去搜尋資料 - Excel程式區

　暱稱: 蝕光迴狼

帖子: 75
主題: 6
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
來自: 臺灣
註冊時間: 2014-9-22
最後登錄: 2015-3-7

論壇榮譽勳章論壇贊助勳章

8^# 跳轉到 »

發表於 2014-10-2 16:20 | 只看該作者

本帖最後由蝕光迴狼於 2014-10-2 16:22 編輯

回復 7# GBKEE

Dear GBKEE 版主您好：

　　　非常感謝你繁忙之間抽空幫忙。

　　　1. 您寫的程式，可以抓到子資料夾底下的檔案。

　　　2. 程式迴圈的方式是我最弱的項目，所以看不太懂，不容易我從中學習。

　　　3. 有個地方不明白，執行後並不會依關鍵字去複製檔案，反而複製資料夾底下全部的檔案。

　附件中的檔案是我用 Hsieh 版主大人，幫我寫的程式去做修改的，
　
　目前的瓶頸是不知道，要怎麼改程式才能 搜尋與複製　子資料夾底下的檔案？

　●會這樣寫是為了日後方便做維護與修改程式碼。再次謝謝 GBKEE 版主大大

Private Sub CommandButton1_Click()
DM = "D:\測試用\" '搜尋主路徑
ML1 = Range("E3") '搜尋檔案資料夾目錄一
ML2 = Range("E5") '搜尋檔案資料夾目錄二
ML3 = Range("E7") '搜尋檔案關鍵字
gb = "D:\" & ML3 & "\" '存檔位置
Set fsd = CreateObject("Scripting.FileSystemObject")
fd = DM & ML1 & "\" & ML2 & "\" '檔案資料夾位置
fs = Dir(fd & "*" & ML3 & "*") '測試關鍵字檔名是否存在
If fs <> "" Then
If fsd.folderexists(gb) = False Then fsd.createfolder gb '自創資料夾不存在則建立
fsd.copyfile fd & "*" & ML3 & "*", gb '複製檔案
Else
Exit Sub '結束程式
End If
End Sub

複製代碼

樣本.rar (10.92 KB)

測試用.rar (10.16 KB)

我很笨,所以我很用心
　我學藝不精,但我渴求知識

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

7^#

發表於 2014-10-2 10:28 | 只看該作者

回復 6# 蝕光迴狼
對話框試試看

Sub Ex()
With Application.FileDialog(msoFileDialogFolderPicker) '開啟資料夾的對話框
If .Show = True Then
If MsgBox(.SelectedItems(1) & " 中搜尋 *" & TextBox3, vbYesNo) = vbYes Then
If Dir("D:\自創資料夾", vbDirectory) = "" Then MkDir ("D:\自創資料夾") '自創資料夾不存在則建立
TextBox1 = .SelectedItems(1)
副程式 .SelectedItems(1)
End If
End If
End With
End Sub
Private Sub 副程式(資料夾 As String)
Dim Fs As Object, F As Object
Set Fs = CreateObject("Scripting.FileSystemObject")
If Dir(資料夾 & "\*" & TextBox3 & "*") <> "" Then '測試關鍵字檔名是否存在
Fs.copyfile 資料夾 & "\*" & TextBox3 & "*", "D:\自創資料夾"
End If
'*** 如資料夾下有子資料夾再呼叫這副.程式 ***
'呼叫程式的迴圈
For Each F In Fs.GetFolder(資料夾).SUBFolderS
Debug.Print F '可看一下子資料夾名稱
副程式 F & ""
Next
End Sub

複製代碼

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

　暱稱: 蝕光迴狼

帖子: 75
主題: 6
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
來自: 臺灣
註冊時間: 2014-9-22
最後登錄: 2015-3-7

論壇榮譽勳章論壇贊助勳章

6^#

發表於 2014-10-1 19:21 | 只看該作者

回復 4# Hsieh

Dear Hsieh 版主：

　再請問如果連子資料夾，底下的檔案也要全部尋找複製，

　要加入什麼指令? 加在哪一行 ?

　謝謝

我很笨,所以我很用心
　我學藝不精,但我渴求知識

　暱稱: 蝕光迴狼

帖子: 75
主題: 6
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
來自: 臺灣
註冊時間: 2014-9-22
最後登錄: 2015-3-7

論壇榮譽勳章論壇贊助勳章

5^#

發表於 2014-10-1 17:57 | 只看該作者

回復 4# Hsieh

Dear Hsieh：

　　　真的由衷感謝你的幫助，這幫了我很大的忙，

　　　因為我沒有任何的基礎，所以剛起步對我這初學者來說很辛苦，

　　　我會努力的，到時還請各位高手與　Hsieh　大大多多費心了，謝謝～

我很笨,所以我很用心
　我學藝不精,但我渴求知識

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

4^#

發表於 2014-10-1 16:18 | 只看該作者

回復 3# 蝕光迴狼
試試看

Private Sub CommandButton1_Click()
Set fsd = CreateObject("Scripting.FileSystemObject")
fd = "\\D1502111\暫存區\" & TextBox1 & "\" & TextBox2 & "\" '檔案資料夾位置
fs = Dir(fd & "*" & TextBox3 & "*") '測試關鍵字檔名是否存在
If fs <> "" Then
If fsd.folderexists("D:\自創資料夾") = False Then fsd.createfolder "D:\自創資料夾" '自創資料夾不存在則建立
fsd.copyfile fd & "*" & TextBox3 & "*", "D:\自創資料夾" '複製檔案
Else
Exit Sub
End If
End Sub

複製代碼

學海無涯_不恥下問

　暱稱: 蝕光迴狼

帖子: 75
主題: 6
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
來自: 臺灣
註冊時間: 2014-9-22
最後登錄: 2015-3-7

論壇榮譽勳章論壇贊助勳章

3^#

發表於 2014-10-1 14:28 | 只看該作者

麻煩各位幫幫忙了，如果Excel程式，無法達到我想要的效果，
也請好心告訴我一下，程式辦不到，讓我早點死心放棄．．．．．
謝謝各位熱心的高手大大，十分感謝，百分感謝，千分感謝，萬分感謝，千萬分感謝，
我也是看到此網站，有很多熱心且不求回報的高手大大在，
並想要讓此網站永續經營，也用行動表示我的誠意，
不要讓我的求助文，沉淪拜託～

我很笨,所以我很用心
　我學藝不精,但我渴求知識

　暱稱: 蝕光迴狼

帖子: 75
主題: 6
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: Office 2003
閱讀權限: 20
性別: 男
來自: 臺灣
註冊時間: 2014-9-22
最後登錄: 2015-3-7

論壇榮譽勳章論壇贊助勳章

2^#

發表於 2014-10-1 13:16 | 只看該作者

有沒有高手幫幫我,拜託,因為VBA我不是很熟,
我都是看別人的程式在土法煉鋼......

我很笨,所以我很用心
　我學藝不精,但我渴求知識