工作表不固定单元格信息汇总-前辈们帮帮忙

hongshan2019

半百 发表于 2024-2-1 15:24
请测试。。。

老师思路清奇，又学到了

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr, i&, j&, r&, strFileName$, strPath$
   
    Application.ScreenUpdating = False
   
    With [A1].CurrentRegion
        .Offset(1).ClearContents
        ar = .Resize(10 ^ 3)
        r = 1
    End With
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                With .Worksheets(1)
                    cr = Range(.[C12], .Cells(Rows.Count, "I").End(xlUp)).Value
                    For i = 2 To UBound(cr)
                        r = r + 1
                        br = [{6,4;6,6;6,9;8,4;8,6;8,9;10,9}]
                        For j = 1 To UBound(br)
                            ar(r, j) = .Cells(br(j, 1), br(j, 2))
                        Next j
                        br = [{8,1;9,2;10,5;11,7}]
                        For j = 1 To UBound(br)
                            ar(r, br(j, 1)) = cr(i, br(j, 2))
                        Next j
                    Next i
                End With
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    [A1].Resize(r, UBound(ar, 2)) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。