以Excel VBA做资料搜寻系统... 寻求高手帮助!!!

各位大哥大姊高手们好~
小弟日前受主管们指示...
要做出内网的资料库搜寻系统...
讨论了很久
以及技术上的困难(不是专业写程式/程式新手)...
所以最后採纳某个大主管的意见

用Excel VBA建立搜寻系统
(不要问我为什么不用资料夹内建的搜寻功能="=a)

大主管用自己的能力
和下班闲余时间
自己花时间测试了大部分的东西
功能如下(大概):

透过Excel搜寻特定共用网路硬碟的资料夹(网路芳邻?)可以依照档名进行搜寻可以依照档案内容进行搜寻(要提前一个一个複製内容)可以搜寻到后进行超连结打开档案半自动抓取固定资料夹内的档案,然后自行新增资料半自动在新增资料后,建立超连结

主管大部分都做好了
但他只是测试
只能在那个测试的资夹运作
剩下他就交给我处理了...
但我看不懂 ="=a
我遇到的问题是:

如何设定抓资料的範围(目标资料夹)?如何让资料自动建立超连结?若目标资料夹移动,或档名更动,或执行的Excel档案移动或档名更动,需要做哪些调整?每个指令的功用...

执行的介面是这样

接着是重点,指令等程式语言了...
共有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


关于作者: 网站小编

码农网专注IT技术教程资源分享平台,学习资源下载网站,58码农网包含计算机技术、网站程序源码下载、编程技术论坛、互联网资源下载等产品服务,提供原创、优质、完整内容的专业码农交流分享平台。

热门文章