[求助] execl批量提取文件夹下所有表格的固定单元格的值

5101314zt

execl批量提取文件夹下所有表格的固定单元格的值(其中家庭人口非现成数据，需运算) ，求助大佬指点。

乐乐2006201505

Sub ExtractCellValuesFromExcelFiles()
    Dim SourceFolder As String
    Dim FileName As String
    Dim SourceWorkbook As Workbook
    Dim DestSheet As Worksheet
    Dim LastRow As Long
    Dim CellAddress As String
   
    ' 设置源文件夹路径
    SourceFolder = "C:\Your\Path\Here\" ' 请替换为你的文件夹路径
    ' 设置要提取的单元格地址
    CellAddress = "A1" ' 请根据需要修改单元格地址
   
    ' 创建目标工作表
    Set DestSheet = ThisWorkbook.Sheets.Add
    DestSheet.Name = "ExtractedData"
   
    ' 初始化目标工作表的行号
    LastRow = 1
   
    ' 遍历文件夹中的所有Excel文件
    FileName = Dir(SourceFolder & "*.xls*") ' 支持.xls和.xlsx文件
    Do While FileName <> ""
        ' 打开源Excel文件
        Set SourceWorkbook = Workbooks.Open(SourceFolder & FileName)
        
        ' 提取指定单元格的值
        DestSheet.Cells(LastRow, 1).Value = SourceWorkbook.Sheets(1).Range(CellAddress).Value
        DestSheet.Cells(LastRow, 2).Value = FileName ' 将文件名也复制到工作表中
        
        ' 关闭源工作簿
        SourceWorkbook.Close False
        ' 更新行号
        LastRow = LastRow + 1
        
        ' 获取下一个文件名
        FileName = Dir()
    Loop
   
    ' 通知用户操作完成
    MsgBox "所有文件的指定单元格值已提取完毕！"
End Sub

自己根据实际再修改一下。

李波001

Sub TQsj()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim ws As Worksheet, wb As Workbook, sh As Worksheet, p As String, f As String, arr() As Variant, brr() As Variant, r As Long,  C As Long
    Set ws = ThisWorkbook.Sheets(1)
    p = ThisWorkbook.Path & "\aa\" '设置路径
    f = Dir(p)
    arr = ws.[a1].CurrentRegion.Value ' 初始化数组
    ReDim brr(1 To 999, 1 To 10)
    r = 1
    Do While f <> ""
        Set wb = Workbooks.Open(p & f)
        Set sh = wb.Sheets(1)
        brr(r, 1) = f
        brr(r, 2) = sh.Name
        brr(r, 3) = Right(sh.Cells(3, "A").Value, Len(sh.Cells(3, "A").Value) - InStr(sh.Cells(3, "A").Value, "地区3：") - 3)
        brr(r, 4) = sh.Cells.Find("户主").Offset(0, -2).Value
        brr(r, 5) = Application.WorksheetFunction.CountA(sh.Range("B9:B17"))
        brr(r, 10) = Right(sh.Cells(44, "A").Value, Len(sh.Cells(44, "A").Value) - InStr(sh.Cells(44, "A").Value, "："))
        For C = 6 To 9
            If arr(8, C) <> "" Then brr(r, C) = sh.Range(arr(8, C)).Value
        Next C
        r = r + 1
        wb.Close SaveChanges:=False
        f = Dir
    Loop
    ' 将结果写入工作表
    ws.[a10].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

李波001

试试