Sub 汇总工作簿关键字指定列()
Dim ws As Worksheet
Dim wb As Workbook
Dim fd As FileDialog
Dim strPath As String
Dim strKeyword As String
Dim rng As Range
Dim i As Long, j As Long
Dim colIndex As Long
' 设置关键字
strKeyword = InputBox("请输入要汇总的关键字（多个关键字用逗号分隔）：", "关键字")
colIndex = InputBox("请输入要汇总的列索引（从1开始）：", "列索引")
' 选择文件夹
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
strPath = fd.SelectedItems(1)
Else
Exit Sub
End If
' 创建新工作表
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = "汇总结果"
' 遍历文件夹中的工作簿
strPath = strPath & "\"
strKeyword = Split(strKeyword, ",")
For Each strKeyword In strKeyword
For Each wb In Workbooks
If wb.Path <> ThisWorkbook.Path And Right(wb.Name, 4) = "xlsx" Then
On Error Resume Next
Set rng = wb.Worksheets(1).Cells.Find(strKeyword)
If Not rng Is Nothing Then
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
ws.Cells(ws.Cells(Rows.Count, 1).End(xlUp).Row + 1, j).Value = rng.Cells(i, j).Value
Next j
Next i
End If
On Error GoTo 0
End If
Next wb
Next strKeyword
MsgBox "汇总完成！"
End Sub
发表于 2024-5-16 14:00
|
发表于 2024-5-16 14:44
