|
|
楼主 |
发表于 2024-8-4 16:15
|
显示全部楼层
Sub ExtractDataBasedOnCriteria()
Dim wb As Workbook
Dim ws As Worksheet
Dim mainWb As Workbook
Dim targetRow As Long, targetValue As Long
Dim filePath As String, fileName As String
Dim folder As Object
Dim cell As Range
Dim foundColumn As Range
Dim lastRow As Long, lastCol As Long
Dim colIdentifier As String
Dim copyRng As Range
' 设置主工作簿
Set mainWb = ThisWorkbook
Set ws = mainWb.Sheets(1) ' 假设数据将返回主工作簿的第一个工作表
' 设定目标行和值
targetRow = ws.Range("A1").Value
targetValue = ws.Range("B1").Value
' 获取工作簿所在文件夹路径
filePath = ThisWorkbook.Path
' 使用FileSystemObject遍历文件夹
Set folder = CreateObject("Scripting.FileSystemObject")
' 遍历文件夹中的所有xlsx文件
fileName = Dir(filePath & "\*.xlsb")
Do While fileName <> ""
If fileName <> mainWb.Name Then ' 排除主工作簿
Set wb = Workbooks.Open(filePath & "\" & fileName)
' 遍历工作簿中的所有工作表
For Each sheet In wb.Sheets
lastCol = sheet.Cells(targetRow, sheet.Columns.Count).End(xlToLeft).Column
' 查找第targetRow行中值为targetValue的单元格
Set foundColumn = Nothing
For Each cell In sheet.Rows(targetRow).Cells
If cell.Column <= lastCol And cell.Value = targetValue Then
Set foundColumn = cell
Exit For
End If
Next cell
' 如果找到了，复制数据并标注
If Not foundColumn Is Nothing Then
colIdentifier = Split(Cells(1, foundColumn.Column).Address(True, False), "$")(1)
' 复制列数据到主工作簿
lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
sheet.Columns(foundColumn.Column).Copy Destination:=ws.Cells(lastRow + 1, "E")
' 在复制的数据列最后一行添加工作簿名和列标识
ws.Cells(lastRow + sheet.Cells(sheet.Rows.Count, foundColumn.Column).End(xlUp).Row, "E").Value = fileName & colIdentifier
End If
Next sheet
wb.Close SaveChanges:=False
End If
fileName = Dir()
Loop
MsgBox "数据提取完成！"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-4 16:14
