iT邦幫忙

0

以Excel VBA做資料搜尋系統... 尋求高手幫助!!!

各位大哥大姊高手們好~
小弟日前受主管們指示...
要做出內網的資料庫搜尋系統...
討論了很久
以及技術上的困難(不是專業寫程式/程式新手)...
所以最後採納某個大主管的意見

用Excel VBA建立搜尋系統
(不要問我為什麼不用資料夾內建的搜尋功能="=a)

大主管用自己的能力
和下班閒餘時間
自己花時間測試了大部分的東西
功能如下(大概):

  1. 透過Excel搜尋特定共用網路硬碟的資料夾(網路芳鄰?)
  2. 可以依照檔名進行搜尋
  3. 可以依照檔案內容進行搜尋(要提前一個一個複製內容)
  4. 可以搜尋到後進行超連結打開檔案
  5. 半自動抓取固定資料夾內的檔案,然後自行新增資料
  6. 半自動在新增資料後,建立超連結

主管大部分都做好了
但他只是測試
只能在那個測試的資夾運作
剩下他就交給我處理了...
但我看不懂 ="=a
我遇到的問題是:

  1. 如何設定抓資料的範圍(目標資料夾)?
  2. 如何讓資料自動建立超連結?
  3. 若目標資料夾移動,或檔名更動,或執行的Excel檔案移動或檔名更動,需要做哪些調整?
  4. 每個指令的功用...

執行的介面是這樣

接著是重點,指令等程式語言了...
共有3個模組~

第一個模組是:

內容是:

Sub getnewall()
'
' getnewall 巨集
'allall=FILES("H:\工作資料夾*.*")
'
Dim LR As Long, i As Long
'
ActiveWorkbook.Worksheets("新下載資料").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.FormulaArray = "=newall"
Selection.Copy
Range("b2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.Worksheets("新下載資料").Rows(1).ClearContents
Worksheets("新下載資料").Range("b20000").End(xlUp).Select
LR = Worksheets("新下載資料").Range("b20000").End(xlUp).Row

For i = 1 To LR

If IsError(Cells(i, 2)) Then

Application.Rows(i).ClearContents

End If
Next
'清除原C欄資料 Columns 準備放新資料後再進行連結
Application.Columns(3).Delete

' copyBtoC 巨集
'
Columns("B:B").Select
Selection.Copy
Selection.Insert Shift:=xlToRight
'
' 超連結 巨集

Range("c2").Select
Do While ActiveCell.Value <> Empty
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
ActiveCell.Value, TextToDisplay:= _
ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
Range("a1").Select

End Sub

第二個模組是:
(不知道跟第一個有啥差別?是只有目標資料夾不一樣?)

內容是:

Sub getallall()
'
' getallall 巨集
'allall=FILES("D:\工作資料夾*.*")
'
Dim LR As Long, i As Long
'
ActiveWorkbook.Worksheets("搜尋表").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.FormulaArray = "=allall"
Selection.Copy
Range("b2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.Worksheets("搜尋表").Rows(1).ClearContents
Worksheets("搜尋表").Range("b20000").End(xlUp).Select
LR = Worksheets("搜尋表").Range("b20000").End(xlUp).Row

For i = 1 To LR

If IsError(Cells(i, 2)) Then

Application.Rows(i).ClearContents

End If
Next
'清除原C欄資料 Columns 準備放新資料後再進行連結
Application.Columns(3).Delete

' copyBtoC 巨集
'
Columns("B:B").Select
Selection.Copy
Selection.Insert Shift:=xlToRight
'
' 超連結 巨集

Range("c2").Select
Do While ActiveCell.Value <> Empty
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
ActiveCell.Value, TextToDisplay:= _
ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
Range("a1").Select

End Sub

第三個模組是:
(有四個巨集)



內容是:

Sub 新下載資料match()

' 新下載資料比對舊資料找無則新增
'
''
Dim LA As Long, LB As Long, LC As Long
Dim LR As Long, i As Long, pp As Long
Dim FFN As String, SFN As String, ser_str As String
Dim tr As Object, tn As Object
ActiveWorkbook.Worksheets("搜尋表").Select
LA = Worksheets("搜尋表").Range("c500000").End(xlUp).Row
ActiveWorkbook.Worksheets("新下載資料").Select
LR = Worksheets("新下載資料").Range("c500000").End(xlUp).Row
'MsgBox LR
'Range("c4").Select

LA = LA + 1

'Set tr = Sheets("搜尋結果檔").Cells

'tr.ClearContents

For i = 1 To LR

Sheets("新下載資料").Select

'MsgBox (i)
Cells(i, 1).Select
ActiveCell.FormulaR1C1 = "=MATCH(R[i]C2,搜尋表!R2C2:R[LR]C2,0)"

'Set c = MATCH(R[i]C2,搜尋表!R2C2:R[LR]C2,0)

If IsError(Cells(i, 1)) Then '找不到儲存格時
Application.Cells(i, 1).Value = ""

Set tr = Sheets("新下載資料").Rows(i)

tr.Copy

Sheets("搜尋結果檔").Select

Rows(LA).Select

ActiveSheet.Paste

pp = pp + 1

End If

Next
ActiveWorkbook.Worksheets("搜尋結果檔").Select

End Sub


Sub 檔案超連結()
'暫存測試用
' 檔案超連結 巨集
'

'
Range("C2").Select
Do While ActiveCell.Value <> Empty
ActiveSheet.Hyperlinks.Add Anchor:=Selection,

Address:= _
ActiveCell.Value, TextToDisplay:= _
ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
End Sub


Sub copyBtoC()
'
'暫存測試用
' copyBtoC 巨集
'

'
Columns("B:B").Select
Selection.Copy
Selection.Insert Shift:=xlToRight
End Sub


Sub saaa()
'
' saaa 巨集
'暫存測試用

'
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.FormulaArray = "=allall"
End Sub


其實不太清楚
每個巨集和模組在幹嘛...
尤其是看不太懂主管給巨集取名的意思和裡面的解釋...

我是個Excel新手
對這些有點苦手,請問有大哥大姐高手們...
可以解釋一下
讓我學習和參考嗎?

我知道內容有點多
要求有點過分...飛踢
但希望可以讓我知道每個指令在做什麼...
我才好增加和更改
尤其是令人難以理解的名稱

大致上是這樣
感恩!!! ^^

如果有任何建議,也可以跟我說喔~
或是簡化程式碼也可以~
或是我需一給予更多資料才能協助之類的~
我翻過VBA的書籍滾來滾去
似乎不是短時間可以精通的東西 ="=a
再次謝謝~ ^^

PS:
目前是把同一個資料複製一份放在不同的資料夾裡
一份是常規的一層一層分類去擺放資料
另一份就是專門放在搜尋資料夾讓VBA去抓...
(因為不不知道怎麼一層一層抓資料,但是有點浪費硬碟容量)

VBA會把抓到資料排列好
並附上超連結
(我不知道怎麼執行)

然後點開眼睛
輸入欲搜尋的關鍵字
VBA會自動從列出的資料抓出我們要的資料(檔名or內容之中有關鍵字)

流程是這樣~
跪求高手指點~ Orz


圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

1 則留言

1
paicheng0111
iT邦大師 5 級 ‧ 2018-06-05 10:17:53

這應該放到「技術問答」區,而不是「技術文章」區。
另外,ithelp支援markdown,你可以用Ctrl+Alt+c編輯程式碼。

小魚 iT邦大師 1 級 ‧ 2018-06-05 12:04:41 檢舉

原來可以這樣打啊,
每次都笨笨的`一個一個按...

我要留言

立即登入留言