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

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

直接上代码，请大神给优化一下，智障AI写的，改了好多次了

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 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 & "*.*")
Do While 文件 <> ""
If 文件 Like "*.csv" Or 文件 Like "*.xls" Or 文件 Like "*.xlsx" Then
Set 源工作簿 = Workbooks.Open(源目录1 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
列号 = 源工作表.UsedRange.Columns.Count
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(目标行, 列号 + 1).Value = 源目录1 & " - " & 文件 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
End If
文件 = Dir
Loop
End If
' 处理目录2下的文件
If Dir(源目录2, vbDirectory) <> "" Then
文件 = Dir(源目录2 & "*.*")
Do While 文件 <> ""
If 文件 Like "*.csv" Or 文件 Like "*.xls" Or 文件 Like "*.xlsx" Then
Set 源工作簿 = Workbooks.Open(源目录2 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
列号 = 源工作表.UsedRange.Columns.Count
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(目标行, 列号 + 1).Value = 源目录2 & " - " & 文件 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
End If
文件 = Dir
Loop
End If
' 处理目录3下的文件
If Dir(源目录3, vbDirectory) <> "" Then
文件 = Dir(源目录3 & "*.*")
Do While 文件 <> ""
If 文件 Like "*.csv" Or 文件 Like "*.xls" Or 文件 Like "*.xlsx" Then
Set 源工作簿 = Workbooks.Open(源目录3 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
列号 = 源工作表.UsedRange.Columns.Count
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(目标行, 列号 + 1).Value = 源目录3 & " - " & 文件 & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 行号
Next 源工作表
源工作簿.Close False
End If
文件 = Dir
Loop
End If
' 保存目标工作簿并关闭
Application.DisplayAlerts = False
目标工作簿.SaveAs 目标文件
Application.DisplayAlerts = True
目标工作簿.Close False
MsgBox "汇总完成！"
End Sub

复制代码

grf1973 · 发表于 2023-5-26 10:37

这个应该用数据库处理比较简单

grf1973 · 发表于 2023-5-26 11:39

疑惑的是CSV文件必须打开才能提取。一般xls文件是无需打开的，可以直接用union all把语句串起来。

⑧技术π⑧ · 发表于 2023-5-26 13:35

grf1973 发表于 2023-5-26 10:37
这个应该用数据库处理比较简单

我也想过数据库存储数据然后再读取，不知道有没有这方面的建议，怎么处理

⑧技术π⑧ · 发表于 2023-5-27 16:33

gwjkkkkk 发表于 2023-5-25 20:00
参与一下。。。

不错不错，优秀

⑧技术π⑧ · 发表于 2023-5-27 16:33

ykcbf1100 发表于 2023-5-25 14:54
我做一个吧，模糊查询。

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

不错不错，优秀

⑧技术π⑧ · 发表于 2023-5-27 17:09

gwjkkkkk 发表于 2023-5-25 19:57
Option Explicit
Sub test()
Dim ar, br, i&, j&, r&, f As Object, ff As Object, p$, s

ar(r, j) = br(i, j) 提示下标越界

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

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