数据提取求助

虫马虫义

有多个工作簿，名称不一样，里面格式也有差别，怎么提取需要的数据并汇总到一起，达到下面图片效果，求大神写个代码，万分感谢！！



感谢大神春风化雨的帮助，完美解决了我的问题

3190496160

Sub 提取数据()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
With Sheets("数据提取")
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    .[a1].CurrentRegion.Offset(1).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(1) = Empty
    ar = .Range(.Cells(1, 1), .Cells(5000, y))
    For j = 2 To y
        d(ar(1, j)) = j
    Next j
    f = Dir(lj & "*.xls*")
    n = 1
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(lj & f, 0)
            With wb.Worksheets(1)
                rs = .Cells(Rows.Count, 2).End(xlUp).Row
                ys = .Cells(2, Columns.Count).End(xlToLeft).Column
                br = .Range(.Cells(1, 1), .Cells(rs, ys))
            End With
            For i = 3 To UBound(br)
                If Trim(br(i, 2)) <> "" Then
                    n = n + 1
                    ar(n, 1) = n - 1
                    For j = 2 To UBound(br, 2)
                        lh = d(br(2, j))
                        If lh <> "" Then
                            ar(n, lh) = br(i, j)
                        End If
                    Next j
                End If
            Next i
            wb.Close False
        End If
    f = Dir
    Loop
    .[a1].Resize(n, y) = ar
    .[a1].Resize(n, y).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

新建文件夹.rar (43.56 KB, 下载次数: 20)

2023-12-22 08:45 上传

点击文件名下载附件

sdytsxd991122

练习

虫马虫义

3190496160 发表于 2023-12-22 08:45

谢谢大神！！之前找了几个，不是不能用，就是只能提取格式完全一样的，不一样的每次都需要分开，提取两次在汇总。

虫马虫义

sdytsxd991122 发表于 2023-12-22 10:48
练习

谢谢帮助。楼上大神发的可以完美解决

x-xx-xx

1. Sub Macro1()
   
2.    
   
3.     S20230808_104833_xx "D:\新建文件夹"
   
4.     ActiveSheet.UsedRange.Select
   
5.     S20230806_194223_xx
   
6.    
   
7. End Sub

复制代码

新建文本文档.rar (3.26 KB, 下载次数: 0)

2023-12-22 11:26 上传

点击文件名下载附件

虫马虫义

3190496160 发表于 2023-12-22 08:44
Sub 提取数据()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant

大神你好，这数据标题行是在第二行，如过是在第一行，需要怎么该？

shiruiqiang

虫马虫义 发表于 2024-1-4 15:47
大神你好，这数据标题行是在第二行，如过是在第一行，需要怎么该？

这2个数字均减去1，分别为2和1

虫马虫义

shiruiqiang 发表于 2024-1-4 20:23
这2个数字均减去1，分别为2和1

奇怪了，我之前有改，但是后面2改1后老提示溢出。这次文档关掉的，改了又能正常了。谢谢你！！