vba 查询文件夹下所有excel文件，写入新的excel中

最新推荐文章于 2024-08-13 08:39:15 发布

囝仔996

最新推荐文章于 2024-08-13 08:39:15 发布

阅读量1.9k

点赞数

文章标签：数学建模

本文链接：https://blog.csdn.net/qq_31940749/article/details/131393228

版权

Sub SearchAndConsolidate()
    Dim folderPath As String
    Dim keyword As String
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim file As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim cell As Range
    Dim nextRow As Long
    
    ' 设置文件夹路径和关键字
    folderPath = "C:\myWork\excel\" ' 替换为实际文件夹路径
    keyword = "RELATED_OFFICER_NM" ' 替换为实际关键字
    
    ' 创建新的目标工作簿和工作表
    Set targetWorkbook = Workbooks.Add
    Set targetWorksheet = targetWorkbook.Sheets(1)
    
    ' 设置目标工作表的标题行
    targetWorksheet.Range("A1").Value = "文件名"
    targetWorksheet.Range("B1").Value = "工作表名"
	targetWorksheet.Range("C1").Value = "カラム名 *"
	targetWorksheet.Range("D1").Value = "データ型 *"
	targetWorksheet.Range("E1").Value = "サイズ(桁) *"
	targetWorksheet.Range("F1").Value = "デフォルト値"
	targetWorksheet.Range("G1").Value = "説明"
	targetWorksheet.Range("H1").Value = "論理名"
    targetWorksheet.Range("I1").Value = "关键字出现次数"
    
    ' 获取文件夹下的所有文件
    file = Dir(folderPath & "*.xls*")
    
    ' 遍历每个文件
    Do While file <> ""
        ' 打开文件
        Set wb = Workbooks.Open(folderPath & file)
        
        ' 遍历每个工作表
        For Each ws In wb.Sheets
            ' 在每个工作表中搜索关键字
            For Each cell In ws.UsedRange
                If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
				
                    ' 如果关键字出现在单元格中，则将相关信息写入目标工作表
                    nextRow = targetWorksheet.Cells(targetWorksheet.Rows.Count, "A").End(xlUp).Row + 1
                    targetWorksheet.Cells(nextRow, "A").Value = file
                    targetWorksheet.Cells(nextRow, "B").Value = Right(ws.Cells(2, 1), 9)  
					targetWorksheet.Cells(nextRow, "C").Value = ws.Cells(cell.Row, "G")
					targetWorksheet.Cells(nextRow, "D").Value = ws.Cells(cell.Row, "L")
					targetWorksheet.Cells(nextRow, "E").Value = ws.Cells(cell.Row, "O")
					targetWorksheet.Cells(nextRow, "F").Value = ws.Cells(cell.Row, "R")
					targetWorksheet.Cells(nextRow, "G").Value = ws.Cells(cell.Row, "Y")
					targetWorksheet.Cells(nextRow, "H").Value = ws.Cells(cell.Row, "B")
                    targetWorksheet.Cells(nextRow, "I").Value = targetWorksheet.Cells(nextRow, "I").Value + 1
                End If
            Next cell
        Next ws
        
        ' 关闭文件
        wb.Close SaveChanges:=False
        
        ' 获取下一个文件
        file = Dir
    Loop
    
    ' 自动调整目标工作表的列宽
    targetWorksheet.Columns.AutoFit
    
    ' 提示完成
    MsgBox "搜索和整理完成！"
End Sub