求教：提取多个表中不同位置的内容或部分内容到新的工作表中

tianyue1 · 发表于 2024-3-13 11:13

1、数据源可能有很多个，放在同一文件夹下，每个数据源名称均为数字+文字；2、数据需求为将文件夹中的每个EXCEL工作簿名字中的数字提取在新建工作簿（表）中的A1,A2,.....；3、将如数据源中第四行、五行、六行标黄部分进行提取放入新工作簿，数据源每个表中第四行仅提取标黄部分的数字部分，提取至B1,B2,.....(第四行提取在B列）;将数据源第五行标黄部分提取至 C1,C,2.....（第五行得取在C列），将数据源第六行中“№ ”后的四个数字提取到D1.D2,....

shiruiqiang · 发表于 2024-3-13 12:08

啰哩啰嗦的这么多，就是这样吧？

tianyue1 · 发表于 2024-3-13 12:14

是的，

tianyue1 · 发表于 2024-3-13 12:14

shiruiqiang 发表于 2024-3-13 12:08
啰哩啰嗦的这么多，就是这样吧？

就是这样的。谢谢

tianyue1 · 发表于 2024-3-13 17:17

shiruiqiang 发表于 2024-3-13 12:08
啰哩啰嗦的这么多，就是这样吧？

能否给我下具体的代码

3190496160 · 发表于 2024-3-13 18:57

Sub 数据汇总()
Application.ScreenUpdating = False
Dim ar()
ReDim ar(1 To 50000, 1 To 4)
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(lj & f, 0)
      n = n + 1
      ar(n, 1) = Split(wb.Name, ".")(0)
      With wb.Worksheets(1)
         For i = 4 To 6
            ar(n, i - 2) = .Cells(i, 1)
         Next i
      End With
      wb.Close False
End If
f = Dir
Loop
If n = "" Then MsgBox "没有需要汇总的数据！": End
With ActiveSheet
.UsedRange = Empty
.[a2].Resize(n, 4) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-3-13 19:44

数据及需求.rar (80.13 KB, 下载次数: 7)

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

[求助] 求教：提取多个表中不同位置的内容或部分内容到新的工作表中

评分