请求一段依据列字段提取列数据的VBA代码

HZ1011

各位大神，我有一个数据收集的文件夹，文件夹下有类似很多个名为AC,BC的表格，表格中列的位置不固定。需要实现的功能为：批量将数据文件夹下的表格的内容，按照设定的表头，将多列的数据提取到汇总表中
例如需要提列的表头为：项目名称，序号，名称，发电量，耗电量，暴风停机小时数

HZ1011

附件资料，感谢各位大神

3190496160

Excel vba小白求个代码-ExcelVBA程序开发-ExcelHome技术论坛 - http://club.excelhome.net/forum. ... ;page=1#pid10417284
这个帖子，8楼的代码基本可以满足你，稍微修改即可，

3190496160

Sub zhengli()
Dim d As Object
Dim ar As Variant, br As Variant
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    .[a1].CurrentRegion.Offset(1) = Empty
    arr = .Range("a1:f50000")
    For j = 1 To UBound(arr, 2)
        If Trim(arr(1, j)) <> "" Then
            d(Trim(arr(1, j))) = j
        End If
    Next j
    n = 1
    f = Dir(ThisWorkbook.Path & "\数据\*.xls*")
    Do While f <> ""
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\数据\" & f, 0)
        br = wb.Worksheets(1).[a1].CurrentRegion
        For i = 2 To UBound(br)
            If Trim(br(i, 1)) <> "" Then
                n = n + 1
                For j = 1 To UBound(br, 2)
                    m = d(Trim(br(1, j)))
                    If m <> "" Then
                        arr(n, m) = br(i, j)
                    End If
                Next j
            End If
        Next i
        wb.Close False
    f = Dir
    Loop
    .[a1].Resize(n, UBound(arr, 2)) = arr
End With
End Sub

3190496160

必须保证列标题字段名称一致

HZ1011

3190496160 发表于 2020-7-22 09:37
必须保证列标题字段名称一致

感谢。老师的帮助，此段代码达到了我想要的数据，，感谢