iT邦幫忙

0

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

  • 分享至 

  • xImage

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

用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

看更多先前的討論...收起先前的討論...
你沒提供`allall` 函數與 `newall`函數
q00153 iT邦新手 3 級 ‧ 2018-06-05 13:51:27 檢舉
@@~
俺記得 1~4 點需求都有免費軟體可供使用了
搜尋起來又快又多功能
第 5 點需求 "半自動抓取固定資料夾內的檔案,然後自行新增資料"
寫隻小程式就可以了

良心建議不要用 VBA 做大量檔案搜尋這件事....因為效能問題
art4444 iT邦新手 5 級 ‧ 2018-06-06 09:41:29 檢舉
1. 資料太敏感和蘊含大量機密性的個資 ,所以不能用外面的軟體(Ex: Google)
2. 我不會寫專業的程式 ,本來想試著努力... 但連方向都沒有,如果有教學網站可以提供,我會很感激!!!
3. 因為技術上的困難 ,考慮過把資料庫架在內網上 ,但是網站的程式語言更多更複雜(什麼前端後端的)... 設計得太簡單又無法滿足要求 ,在資料庫沒那麼龐大且限定查詢特定資料的情況下,才使用VBA(這是大主管自己的"建議")...
art4444 iT邦新手 5 級 ‧ 2018-06-06 09:45:51 檢舉
getallall = allall / getnewall = newall
圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

1 個回答

0
海綿寶寶
iT邦大神 1 級 ‧ 2018-06-06 08:59:51

我的建議是
把程式碼退回去給大主管,請他修改
1.把程式功能寫完整
2.對所有變數命名做說明
3.每一列程式碼都加上註解說明
這樣你才比較好接手修改

art4444 iT邦新手 5 級 ‧ 2018-06-06 09:49:07 檢舉

大主管太忙了...
退回給大主管...
感覺我變成主管了!!! XD
這只是他大發慈悲抽空弄的~
TxT
所以我才來求高手幫忙...

我要發表回答

立即登入回答