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

⑧技术π⑧ · 发表于 2023-5-22 16:21

本帖最后由 ⑧技术π⑧ 于 2023-5-25 11:22 编辑

有没有大神帮忙给弄一个

1.每个文件夹都有多个csv格式(或xls、xlsx格式)的文件；
2.每个文件的首行标题都是一致的；
3.根据旁边的查询条件，满足其中一个或者多个的情况下，遍寻文件夹内的文件提取满足对应条件的内容汇总到表格中

gwjkkkkk · 发表于 2023-5-22 18:50

建议模拟一些数据，并模拟一下结果。。。

mmwwdd · 发表于 2023-5-22 19:13

Sub SearchFiles()
'查询条件
Dim keyword1 As String
Dim keyword2 As String
keyword1 = "条件1"
keyword2 = "条件2"

'文件夹路径
Dim folderPath As String
folderPath = "文件夹路径"

'新建工作表
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "汇总表"

'遍历文件夹内的文件
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim folder As Object
Set folder = fs.GetFolder(folderPath)
Dim file As Object
For Each file In folder.files
      '判断文件类型
      If InStr(1, file.Name, ".csv", vbTextCompare) > 0 Or InStr(1, file.Name, ".xls", vbTextCompare) > 0 Or InStr(1, file.Name, ".xlsx", vbTextCompare) > 0 Then
         '打开文件
         Dim wb As Workbook
         Set wb = Workbooks.Open(file.Path)
         Dim wsData As Worksheet
         Set wsData = wb.Sheets(1)

         '查找关键字
         Dim rngSearch As Range
         Set rngSearch = wsData.Rows(1).Find(keyword1, LookIn:=xlValues, LookAt:=xlWhole)
         If Not rngSearch Is Nothing Then
            Dim colNum As Integer
            colNum = rngSearch.Column

            '复制数据到汇总表
            Dim lastRow As Long
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ws.Range("A" & lastRow + 1 & ":Z" & lastRow + 1).Value = wsData.Range(wsData.Cells(2, 1), wsData.Cells(wsData.Rows.Count, colNum)).Value
         End If

         '查找关键字
         Set rngSearch = wsData.Rows(1).Find(keyword2, LookIn:=xlValues, LookAt:=xlWhole)
         If Not rngSearch Is Nothing Then
            Dim colNum As Integer
            colNum = rngSearch.Column

            '复制数据到汇总表
            Dim lastRow As Long
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ws.Range("A" & lastRow + 1 & ":Z" & lastRow + 1).Value = wsData.Range(wsData.Cells(2, 1), wsData.Cells(wsData.Rows.Count, colNum)).Value
         End If

         '关闭文件
         wb.Close False
      End If
Next file
End Sub
以上是ChatGPT回答

⑧技术π⑧ · 发表于 2023-5-23 10:27

mmwwdd 发表于 2023-5-22 19:13
Sub SearchFiles()
'查询条件
Dim keyword1 As String

Dim colNum As Integer 当前范围内的声明重复

⑧技术π⑧ · 发表于 2023-5-23 10:36

gwjkkkkk 发表于 2023-5-22 18:50
建议模拟一些数据，并模拟一下结果。。。

嗯，增加了模拟的数据，就是简单的把搜索到的数据整行汇总在一起

·遁去的一· · 发表于 2023-5-25 01:33

我也想要啊，我试试智障AI能写不能写

⑧技术π⑧ · 发表于 2023-5-25 11:21

·遁去的一· 发表于 2023-5-25 01:33
我也想要啊，我试试智障AI能写不能写

AI有帮你写了吗，

吴中泉 · 发表于 2023-5-25 11:38

·遁去的一· 发表于 2023-5-25 01:33
我也想要啊，我试试智障AI能写不能写

这个AI哪里能下载?或在哪个网站登录?免费使用吗?

·遁去的一· · 发表于 2023-5-25 14:11

吴中泉发表于 2023-5-25 11:38
这个AI哪里能下载?或在哪个网站登录?免费使用吗?

网页版啊，免费使用，但是不敢发，怕被封号啊，你自己搜一下，chatgpt

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

⑧技术π⑧ 发表于 2023-5-23 10:36
嗯，增加了模拟的数据，就是简单的把搜索到的数据整行汇总在一起

AI智障写的，没调试，100%有错误的地方，得自己调试以后再改一下，结构和思路应该是对的

Sub 汇总数据()
Dim 源目录1 As String
Dim 源目录2 As String
Dim 条件1 As String
Dim 条件2 As String
Dim 目标文件 As String
Dim 目标工作表 As Worksheet
Dim 源工作簿 As Workbook
Dim 源工作表 As Worksheet
Dim 目标行 As Long
Dim 最大条件数 As Integer
Dim 符合条件 As Boolean
' 弹窗选择源目录
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")
目标文件 = "C:\目标目录\目标文件.xlsx" ' 替换为您的目标文件路径
' 创建目标文件并获取目标工作表
Set 目标工作表 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
目标行 = 1
' 检查最大条件数
最大条件数 = 2
If 条件2 = "" Then
最大条件数 = 1
End If
' 处理目录1下的文件
If Dir(源目录1, vbDirectory) <> "" Then
文件 = Dir(源目录1 & "*.xlsx")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录1 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
符合条件 = False
For i = 1 To 最大条件数
If i = 1 And 条件1 <> "" Then
If 源工作表.Cells(1, 1).Value = 条件1 Then
符合条件 = True
End If
ElseIf i = 2 And 条件2 <> "" Then
If 源工作表.Cells(1, 2).Value = 条件2 Then
符合条件 = True
End If
End If
Next i
If 符合条件 Then
目标工作表.Cells(目标行, 1).Resize(1, 源工作表.UsedRange.Columns.Count).Value = 源工作表.Cells(1, 1).Resize(1, 源工作表.UsedRange.Columns.Count).Value
目标工作表.Cells(目标行, 源工作表.UsedRange.Columns.Count + 1).Value = 文件 & " - " & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 处理目录2下的文件
If Dir(源目录2, vbDirectory) <> "" Then
文件 = Dir(源目录2 & "*.xlsx")
Do While 文件 <> ""
Set 源工作簿 = Workbooks.Open(源目录2 & 文件)
For Each 源工作表 In 源工作簿.Worksheets
符合条件 = False
For i = 1 To 最大条件数
If i = 1 And 条件1 <> "" Then
If 源工作表.Cells(1, 1).Value = 条件1 Then
符合条件 = True
End If
ElseIf i = 2 And 条件2 <> "" Then
If 源工作表.Cells(1, 2).Value = 条件2 Then
符合条件 = True
End If
End If
Next i
If 符合条件 Then
目标工作表.Cells(目标行, 1).Resize(1, 源工作表.UsedRange.Columns.Count).Value = 源工作表.Cells(1, 1).Resize(1, 源工作表.UsedRange.Columns.Count).Value
目标工作表.Cells(目标行, 源工作表.UsedRange.Columns.Count + 1).Value = 文件 & " - " & 源工作表.Name
目标行 = 目标行 + 1
End If
Next 源工作表
源工作簿.Close False
文件 = Dir
Loop
End If
' 保存目标文件并关闭
Application.DisplayAlerts = False
目标工作表.Parent.SaveAs 目标文件
Application.DisplayAlerts = True
目标工作表.Parent.Close False
MsgBox "汇总完成！"
End Sub

复制代码

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

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