按条件遍寻文件内容提取数据

ykcbf1100 · 发表于 2023-5-25 14:54

我做一个吧，模糊查询。

这个题目有二个难点吧，一是多目录提取文件名，二是模糊查询

·遁去的一· · 发表于 2023-5-25 16:15

经过多次调教智障AI，得出以下代码，可运行，但是速度喜人啊，求大神优化

·遁去的一· · 发表于 2023-5-25 16:23

Sub 汇总数据()
Dim 源目录1 As String
Dim 源目录2 As String
Dim 条件1 As String
Dim 条件2 As String
Dim 目标文件 As String
Dim 目标工作簿 As Workbook
Dim 目标工作表 As Worksheet
Dim 源工作簿 As Workbook
Dim 源工作表 As Worksheet
Dim 目标行 As Long
Dim 文件 As String
Dim 符合条件 As Boolean
Dim 单元格 As Range
Dim 值 As Variant
' 弹窗选择源目录
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择源目录1"
.AllowMultiSelect = False
If .Show = -1 Then
源目录1 = .SelectedItems(1) & ""
Else
MsgBox "未选择源目录1。"
Exit Sub
End If
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择源目录2"
.AllowMultiSelect = False
If .Show = -1 Then
源目录2 = .SelectedItems(1) & ""
Else
MsgBox "未选择源目录2。"
Exit Sub
End If
End With
' 设置条件
条件1 = InputBox("请输入条件1")
条件2 = InputBox("请输入条件2")
目标文件 = "d:\目标文件.xlsX" ' 替换为您的目标文件路径
' 创建目标工作簿并获取目标工作表
Set 目标工作簿 = Workbooks.Add
Set 目标工作表 = 目标工作簿.Worksheets(1)
目标行 = 1
' 处理目录1下的文件
If Dir(源目录1, vbDirectory) <> "" Then
文件 = Dir(源目录1 & "*.xls*")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录1 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
For Each 行号 In 源工作表.UsedRange.Rows
符合条件 = False
For Each 单元格 In 行号.Cells
值 = 单元格.Value
If (条件1 = "" Or InStr(1, 值, 条件1, vbTextCompare) > 0) Or (条件2 = "" Or InStr(1, 值, 条件2, vbTextCompare) > 0) Then
符合条件 = True
Exit For ' 找到符合条件的单元格后退出当前循环
End If
Next 单元格
If 符合条件 Then
行号.Copy ' 复制整行数据
目标工作表.Cells(目标行, 1).PasteSpecial xlPasteAll ' 保留原格式粘贴
目标工作表.Cells(目标行, 行号.Cells.Count + 1).Value = 文件 & " - " & 源目录1 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 处理目录2下的文件
If Dir(源目录2, vbDirectory) <> "" Then
文件 = Dir(源目录2 & "*.xls*")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录2 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
For Each 行号 In 源工作表.UsedRange.Rows
符合条件 = False
For Each 单元格 In 行号.Cells
值 = 单元格.Value
If (条件1 = "" Or InStr(1, 值, 条件1, vbTextCompare) > 0) Or (条件2 = "" Or InStr(1, 值, 条件2, vbTextCompare) > 0) Then
符合条件 = True
Exit For ' 找到符合条件的单元格后退出当前循环
End If
Next 单元格
If 符合条件 Then
行号.Copy ' 复制整行数据
目标工作表.Cells(目标行, 1).PasteSpecial xlPasteAll ' 保留原格式粘贴
目标工作表.Cells(目标行, 行号.Cells.Count + 1).Value = 文件 & " - " & 源目录2 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 保存目标工作簿并关闭
Application.DisplayAlerts = False
目标工作簿.SaveAs 目标文件
Application.DisplayAlerts = True
目标工作簿.Close False
MsgBox "汇总完成！"
End Sub

复制代码

gwjkkkkk · 发表于 2023-5-25 19:57

Option Explicit
Sub test()
Dim ar, br, i&, j&, r&, f As Object, ff As Object, p$, s

Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Trim([E2].Value) <> "" Then s = [E2].Value Else Exit Sub

With Sheets(2)
      With .[A1].CurrentRegion
      .Offset(1).Clear
      ar = .Resize(1000)
      r = 1
      End With
End With
p = ThisWorkbook.Path & "\"
For Each ff In CreateObject("Scripting.FileSystemObject").GetFolder(p).subfolders
      For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(ff.Path).Files
         If f.Name Like "*.csv" Then
            With GetObject(f)
                  br = .Sheets(1).[A1].CurrentRegion
                  For i = 2 To UBound(br)
                     If br(i, 5) = s Then
                        r = r + 1
                        For j = 1 To UBound(ar, 2)
                              ar(r, j) = br(i, j)
                        Next j
                     End If
                  Next i
                  .Close False
            End With
         End If
      Next
Next

With Sheets(2)
      With .[A1].Resize(r, UBound(ar, 2))
         .Value = ar
         .HorizontalAlignment = xlCenter
         .Borders.LineStyle = xlContinuous
      End With
      .Activate
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Beep
End Sub

gwjkkkkk · 发表于 2023-5-25 20:00

参与一下。。。

ykcbf1100 · 发表于 2023-5-25 20:50

·遁去的一· 发表于 2023-5-25 16:23

你把ai写的代码套入楼主的附件中运行一下看看，你这个条件得手工输入的，总共有5个条件，而且，这5个条件允许有空。
我总得，对于复杂的题目，ai写的代码还无能为力。

·遁去的一· · 发表于 2023-5-25 21:26

ykcbf1100 发表于 2023-5-25 20:50
你把ai写的代码套入楼主的附件中运行一下看看，你这个条件得手工输入的，总共有5个条件，而且，这5个条件 ...

我没看楼主的文件，我是从通用的角度去弄的，至于条件那更简单了，只要把设置条件那改一下就行，就是10个也没问题
If (条件1 = "" Or InStr(1, 值, 条件1, vbTextCompare) > 0) Or (条件2 = "" Or InStr(1, 值, 条件2, vbTextCompare) > 0) or (条件3 = "" Or InStr(1, 值, 条件3, vbTextCompare) > 0) Or (条件4 = "" Or InStr(1, 值, 条件4, vbTextCompare) > 0)Then

这只是思路问题，当然要有像您这样的牛人帮我的智障AI再优化一下，我觉得就更好了，以后可以当一个通用功能来用，爽啊

ykcbf1100 · 发表于 2023-5-25 21:59

本帖最后由 ykcbf1100 于 2023-5-25 22:01 编辑

·遁去的一· 发表于 2023-5-25 21:26
我没看楼主的文件，我是从通用的角度去弄的，至于条件那更简单了，只要把设置条件那改一下就行，就是10个 ...

既然你觉得没问题，那你先用这个代码把楼主的问题先解决一下吧。
不要纸上谈兵。

·遁去的一· · 发表于 2023-5-26 01:11

ykcbf1100 发表于 2023-5-25 21:59
既然你觉得没问题，那你先用这个代码把楼主的问题先解决一下吧。
不要纸上谈兵。

智障AI写的，把判断条件弄错了，我晕了，下面这个没问题，亲测，结果文件在D:\目标文件.xlsx

Sub 汇总数据()
Dim 源目录1 As String
Dim 源目录2 As String
Dim 源目录3 As String
Dim 条件1 As String
Dim 条件2 As String
Dim 条件3 As String
Dim 条件4 As String
Dim 条件5 As String
Dim 目标文件 As String
Dim 目标工作簿 As Workbook
Dim 目标工作表 As Worksheet
Dim 源工作簿 As Workbook
Dim 源工作表 As Worksheet
Dim 目标行 As Long
Dim 文件 As String
Dim 符合条件 As Boolean
Dim 单元格 As Range
Dim 值 As Variant
' 弹窗选择源目录
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择源目录1"
.AllowMultiSelect = False
If .Show = -1 Then
源目录1 = .SelectedItems(1) & ""
Else
MsgBox "未选择源目录1。"
Exit Sub
End If
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择源目录2"
.AllowMultiSelect = False
If .Show = -1 Then
源目录2 = .SelectedItems(1) & ""
Else
MsgBox "未选择源目录2。"
Exit Sub
End If
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择源目录3"
.AllowMultiSelect = False
If .Show = -1 Then
源目录3 = .SelectedItems(1) & ""
Else
MsgBox "未选择源目录3。"
Exit Sub
End If
End With
' 设置条件
条件1 = InputBox("请输入条件1")
条件2 = InputBox("请输入条件2")
条件3 = InputBox("请输入条件3")
条件4 = InputBox("请输入条件4")
条件5 = InputBox("请输入条件5")
目标文件 = "d:\目标文件.xlsX" ' 替换为您的目标文件路径
' 创建目标工作簿并获取目标工作表
Set 目标工作簿 = Workbooks.Add
Set 目标工作表 = 目标工作簿.Worksheets(1)
目标行 = 1
' 处理目录1下的文件
If Dir(源目录1, vbDirectory) <> "" Then
文件 = Dir(源目录1 & "*.csv*")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录1 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
For Each 行号 In 源工作表.UsedRange.Rows
符合条件 = False
For Each 单元格 In 行号.Cells
值 = 单元格.Value
If (条件1 <> "" And InStr(1, 值, 条件1, vbTextCompare) > 0) Or (条件2 <> "" And InStr(1, 值, 条件2, vbTextCompare) > 0) Or (条件3 <> "" And InStr(1, 值, 条件3, vbTextCompare) > 0) Or (条件4 <> "" And InStr(1, 值, 条件4, vbTextCompare) > 0) Or (条件5 <> "" And InStr(1, 值, 条件5, vbTextCompare) > 0) Then
符合条件 = True
Exit For ' 找到符合条件的单元格后退出当前循环
End If
Next 单元格
If 符合条件 Then
行号.Copy ' 复制整行数据
目标工作表.Cells(目标行, 1).PasteSpecial xlPasteAll ' 保留原格式粘贴
目标工作表.Cells(目标行, 行号.Cells.Count + 1).Value = 源目录1 & " - " & 文件 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 处理目录2下的文件
If Dir(源目录2, vbDirectory) <> "" Then
文件 = Dir(源目录2 & "*.csv")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录2 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
For Each 行号 In 源工作表.UsedRange.Rows
符合条件 = False
For Each 单元格 In 行号.Cells
值 = 单元格.Value
If (条件1 <> "" And InStr(1, 值, 条件1, vbTextCompare) > 0) Or (条件2 <> "" And InStr(1, 值, 条件2, vbTextCompare) > 0) Or (条件3 <> "" And InStr(1, 值, 条件3, vbTextCompare) > 0) Or (条件4 <> "" And InStr(1, 值, 条件4, vbTextCompare) > 0) Or (条件5 <> "" And InStr(1, 值, 条件5, vbTextCompare) > 0) Then
符合条件 = True
Exit For ' 找到符合条件的单元格后退出当前循环
End If
Next 单元格
If 符合条件 Then
行号.Copy ' 复制整行数据
目标工作表.Cells(目标行, 1).PasteSpecial xlPasteAll ' 保留原格式粘贴
目标工作表.Cells(目标行, 行号.Cells.Count + 1).Value = 源目录2 & " - " & 文件 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 处理目录3下的文件
If Dir(源目录3, vbDirectory) <> "" Then
文件 = Dir(源目录2 & "*.csv")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录2 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
For Each 行号 In 源工作表.UsedRange.Rows
符合条件 = False
For Each 单元格 In 行号.Cells
值 = 单元格.Value
If (条件1 <> "" And InStr(1, 值, 条件1, vbTextCompare) > 0) Or (条件2 <> "" And InStr(1, 值, 条件2, vbTextCompare) > 0) Or (条件3 <> "" And InStr(1, 值, 条件3, vbTextCompare) > 0) Or (条件4 <> "" And InStr(1, 值, 条件4, vbTextCompare) > 0) Or (条件5 <> "" And InStr(1, 值, 条件5, vbTextCompare) > 0) Then
符合条件 = True
Exit For ' 找到符合条件的单元格后退出当前循环
End If
Next 单元格
If 符合条件 Then
行号.Copy ' 复制整行数据
目标工作表.Cells(目标行, 1).PasteSpecial xlPasteAll ' 保留原格式粘贴
目标工作表.Cells(目标行, 行号.Cells.Count + 1).Value = 源目录3 & " - " & 文件 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 保存目标工作簿并关闭
Application.DisplayAlerts = False
目标工作簿.SaveAs 目标文件
Application.DisplayAlerts = True
目标工作簿.Close False
MsgBox "汇总完成！"
End Sub

复制代码

·遁去的一· · 发表于 2023-5-26 09:07

·遁去的一· 发表于 2023-5-26 01:11
智障AI写的，把判断条件弄错了，我晕了，下面这个没问题，亲测，结果文件在D:\目标文件.xlsx

发现个问题，就是当文件格式为xlsx时会报错，应该是列字段数超范围了，还得再改一下

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

[求助] 按条件遍寻文件内容提取数据

评分

评分

评分