逐级搜索功能的实现

高调的鳄鱼 · 发表于 2022-12-6 09:33

源路径       D:\fenxi                                                       输入a       输入b       输入c       输入d       输入e       输入f       输入g       输入h       输入i
保存:       D:\temp\ok                                              手动输入       比5_2       )(3_全双2       (10__趋双
说明:
输入a的功能,直接查找'D:\fenxi'文件夹所有数据,如果文件名包含"输入a",则继续
输入b的功能,在 '输入a'结论中搜索
输入c的功能,在'输入b'的结论搜索
输入d,如果为空,则,输入b为最终结论.输入b的结论,复制文件到"D:\temp\ok"
输入e
输入f,同理,简而言之,就是按,'输入a''输入b''输入c''输入d''输入e''输入f',顺序搜索,得到结论,复制文件到指定文件夹.遇见空值,则停止,

感谢各位. 求赐代码.

test搜索功能.rar (8.7 KB, 下载次数: 9)

高调的鳄鱼 · 发表于 2022-12-6 12:38

大神帮帮

扑腾 · 发表于 2022-12-6 12:49

附件中“分析”文件夹中的表格文件打不开，是怎么回事？，楼主的需求应该可以实现。

高调的鳄鱼 · 发表于 2022-12-6 12:52

扑腾发表于 2022-12-6 12:49
附件中“分析”文件夹中的表格文件打不开，是怎么回事？，楼主的需求应该可以实现。

通过文件名查询,那些是案例文件,打不开正常.

3190496160 · 发表于 2022-12-6 12:53

本帖最后由 3190496160 于 2022-12-6 17:08 编辑

Private Sub TextBox1_Change()
zf = TextBox1.Text
n2 = 0
ReDim br(1 To 1000, 1 To 1)
For i = 1 To n
If InStr(arr(i, 1), zf) > 0 Then
      m = m + 1
      br(m, 1) = arr(i, 1)
End If
Next i
If m <> "" Then
With ListBox1
      .Clear
      .List = br
End With
Else
MsgBox "没有了": Exit Sub
End If
End Sub
Private Sub TextBox2_Change()
zf1 = TextBox1.Text
zf2 = TextBox2.Text
ReDim br(1 To 1000, 1 To 1)
For i = 1 To n
If InStr(arr(i, 1), zf1) > 0 And InStr(arr(i, 1), zf2) > 0 Then
      m = m + 1
      br(m, 1) = arr(i, 1)
End If
Next i
If m <> "" Then
With ListBox1
      .Clear
      .List = br
End With
Else
MsgBox "没有了": Exit Sub
End If
End Sub
Private Sub TextBox3_Change()
zf1 = TextBox1.Text
zf2 = TextBox2.Text
zf3 = TextBox3.Text
ReDim br(1 To 1000, 1 To 1)
For i = 1 To n
If InStr(arr(i, 1), zf1) > 0 And InStr(arr(i, 1), zf2) > 0 And InStr(arr(i, 1), zf3) > 0 Then
      m = m + 1
      br(m, 1) = arr(i, 1)
End If
Next i
If m <> "" Then
With ListBox1
      .Clear
      .List = br
End With
Else
MsgBox "没有了": Exit Sub
End If
End Sub
Private Sub TextBox4_Change()
zf1 = TextBox1.Text
zf2 = TextBox2.Text
zf3 = TextBox3.Text
zf4 = TextBox4.Text
ReDim br(1 To 1000, 1 To 1)
For i = 1 To n
If InStr(arr(i, 1), zf1) > 0 And InStr(arr(i, 1), zf2) > 0 And InStr(arr(i, 1), zf3) > 0 And InStr(arr(i, 1), zf4) > 0 Then
      m = m + 1
      br(m, 1) = arr(i, 1)
End If
Next i
If m <> "" Then
With ListBox1
      .Clear
      .List = br
End With
Else
MsgBox "没有了": Exit Sub
End If
End Sub
Private Sub TextBox5_Change()
zf1 = TextBox1.Text
zf2 = TextBox2.Text
zf3 = TextBox3.Text
zf4 = TextBox4.Text
zf5 = TextBox5.Text
ReDim brr(1 To 1000, 1 To 1)
For i = 1 To n
If InStr(arr(i, 1), zf1) > 0 And InStr(arr(i, 1), zf2) > 0 And InStr(arr(i, 1), zf3) > 0 And InStr(arr(i, 1), zf4) > 0 And InStr(arr(i, 1), zf5) > 0 Then
      k = k + 1
      br(k, 1) = arr(i, 1)
End If
Next i
If k <> "" Then
With ListBox1
      .Clear
      .List = br
End With
Else
MsgBox "没有了": Exit Sub
End If
End Sub
Private Sub UserForm_Initialize()
lj = ThisWorkbook.Path & "\fenxi\"
n = 0
ReDim arr(1 To 1000, 1 To 1)
f = Dir(lj & "*.xls*")
Do While f <> ""
n = n + 1
arr(n, 1) = f
f = Dir
Loop
With ListBox1
.Clear
.List = arr
End With
End Sub

3190496160 · 发表于 2022-12-6 12:55

test搜索功能.rar (21.7 KB, 下载次数: 14)

3190496160 · 发表于 2022-12-6 12:57

1、目前只设置了5级搜索功能，
2、主要思路：逐级搜索后，用一个导入按钮，实现把需要的文件导入到相应文件夹内，
3、目前只写了逐级搜索的代码，导入代码还未写，
4、暂时先看看目前的适不适合再说吧

高调的鳄鱼 · 发表于 2022-12-6 20:39

3190496160 发表于 2022-12-6 12:57
1、目前只设置了5级搜索功能，
2、主要思路：逐级搜索后，用一个导入按钮，实现把需要的文件导入到相应文 ...

感谢老大,我先测一下.

高调的鳄鱼 · 发表于 2022-12-6 20:49

3190496160 发表于 2022-12-6 12:57
1、目前只设置了5级搜索功能，
2、主要思路：逐级搜索后，用一个导入按钮，实现把需要的文件导入到相应文 ...

测后,
1,那个源路径好像没效果?
2,弹窗,没有了,这个可以不需要
3,现在是弹出一个界面,用来测试可以,实际应用,我是希望一键,直接完成.

高调的鳄鱼 · 发表于 2022-12-6 20:56

本帖最后由高调的鳄鱼于 2022-12-6 20:58 编辑

准确无误,一键逐级搜索得到结论.并复制到指定的文件夹.

工作数据,几千上万,也不知vba顶不顶得住

		自动登录	找回密码
密码			免费注册

[求助] 逐级搜索功能的实现

评分

评分