execl批量提取文件夹下所有表格的固定单元格的值(家庭人口需二次运算)

5101314zt · 发表于 2024-8-20 11:45

13570449347 · 发表于 2024-8-20 14:10

很简单得走VBA

沈默00 · 发表于 2024-8-20 14:29

你发错版块了，.
VBA的活，，，就是点苦力活

5101314zt · 发表于 2024-8-20 22:19

13570449347 发表于 2024-8-20 14:10
很简单得走VBA

请来一个vba 可以吗大佬

5101314zt · 发表于 2024-8-20 22:20

沈默00 发表于 2024-8-20 14:29
你发错版块了，.
VBA的活，，，就是点苦力活

大佬可以带我起飞吗请求支援啊

Excel_muke · 发表于 2024-8-21 17:24

1.按alt+f11，进入VBA窗口

2.双击左边ThisWorkbook，输入：

Sub ExtractDataFromWorkbooks()
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim row As Long
Dim wbName As String
Dim wsName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim cellValue As String
Dim householdName As String
Dim region3 As String
Dim peopleCount As Long
Dim perCapitaIncome As Double
Dim targetFolderPath As String
Dim currentWbPath As String
Dim cell As Range
Dim foundCell As Range
' 指定目标工作表（数据将填充到该表）
Set wsTarget = ThisWorkbook.Sheets("Sheet1")
' 获取目标工作簿的文件夹路径
currentWbPath = ThisWorkbook.Path
' 找到最后一行
lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).row
' 从第二行开始循环，提取数据
For row = 2 To lastRow
wbName = wsTarget.Cells(row, 1).Value & ".xlsx" ' 添加 ".xlsx" 后缀
wsName = wsTarget.Cells(row, 2).Value
' 检查指定的工作簿是否在相同的文件夹中
targetFolderPath = currentWbPath & "" & wbName
If Dir(targetFolderPath) = "" Then
MsgBox "工作簿 " & wbName & " 不在目标文件夹中，无法执行操作。", vbExclamation
GoTo NextIteration
End If
' 打开指定工作簿
On Error Resume Next
Set wb = Workbooks.Open(targetFolderPath)
On Error GoTo 0
If Not wb Is Nothing Then
On Error Resume Next
' 获取指定工作表
Set ws = wb.Sheets(wsName)
On Error GoTo 0
If Not ws Is Nothing Then
' C列: 提取 A3 单元格 "地区3:" 后面的非空文字
cellValue = ws.Range("A3").Value
If InStr(cellValue, "地区3：") > 0 Then
region3 = Trim(Mid(cellValue, InStr(cellValue, "地区3：") + Len("地区3：")))
Else
region3 = ""
End If
wsTarget.Cells(row, 3).Value = region3
' D列: 提取户主姓名对应的 B 列数据
householdName = wsTarget.Cells(row, 4).Value
Set foundCell = ws.Columns("D").Find(What:="户主", LookIn:=xlValues, LookAt:=xlPart)
If Not foundCell Is Nothing Then
householdName = ws.Cells(foundCell.row, "B").Value
wsTarget.Cells(row, 4).Value = householdName
Else
wsTarget.Cells(row, 4).Value = "未找到"
End If
' E列: 统计 B9 到 B17 单元格的姓名数量
peopleCount = Application.CountA(ws.Range("B9:B17"))
wsTarget.Cells(row, 5).Value = peopleCount
' F列: 提取 D27 单元格数据
wsTarget.Cells(row, 6).Value = ws.Range("D27").Value
' G列: 提取 O27 单元格数据
wsTarget.Cells(row, 7).Value = ws.Range("O27").Value
' H列: 提取 N39 单元格数据
wsTarget.Cells(row, 8).Value = ws.Range("N39").Value
' I列: 提取 Q27 单元格数据
wsTarget.Cells(row, 9).Value = ws.Range("Q29").Value
' J列: 提取 A44 单元格 "人均收入:" 后面的数字
cellValue = ws.Range("A44").Value
If InStr(cellValue, "人均收入：") > 0 Then
perCapitaIncome = Val(Trim(Mid(cellValue, InStr(cellValue, "人均收入：") + Len("人均收入："))))
Else
perCapitaIncome = 0
End If
wsTarget.Cells(row, 10).Value = perCapitaIncome
Else
MsgBox "无法找到工作表 " & wsName & " 在工作簿 " & wbName, vbExclamation
End If
' 关闭工作簿而不保存更改
wb.Close SaveChanges:=False
Else
MsgBox "无法打开工作簿 " & wbName, vbExclamation
End If
NextIteration:
Next row
MsgBox "数据提取完成！"
End Sub

复制代码

3.按alt+q，退出VBA窗口
4.按alt+f8，启动宏

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

[求助] execl批量提取文件夹下所有表格的固定单元格的值(家庭人口需二次运算)

评分