部分行转置后批量汇总问题

imroy

又来麻烦大神们了，文件夹内有N个工作薄，每个工作薄文件只有一个sheet，需将sheet内的内容转置后汇总到一张表内（附件有样式）：
1、需将工作薄的部分行转置；
2、部分行需转置后用&连接放一个单元格内，每张表内SA代码行数不一致；
3、能否实现文件夹内工作薄批量转置汇总？文件夹内EXCEL文件数量可能有上万个。

转置后汇总.rar (170.08 KB, 下载次数: 10)

2017-7-24 22:11 上传

点击文件名下载附件

原始表：

原始表

汇总表样式：

汇总表

凌空一羽

Sub lkyy()
Dim wb As Workbook, Mp$, Mf
Mp = ThisWorkbook.Path & "\"
Mf = Dir(Mp & "*.xlsx")
ReDim br(1 To 500, 1 To 10)
Do While Mf <> ""
With Workbooks.Open(Mp & Mf)
    n = n + 1
    ar = .Sheets("Page 1").Range("a1").CurrentRegion
    br(n, 1) = ar(3, 2)
    br(n, 2) = ar(4, 2)
    For i = 3 To 9
        br(n, i) = ar(i + 3, 2)
    Next
    For i = 14 To 30
        If i = 14 Then s = ar(i, 1) Else s = s & "|" & ar(i, 1)
    Next
    br(n, 10) = s
    .Close 0
End With
Mf = Dir()
Loop
Range("a2:j1000").ClearContents
Range("a2").Resize(n, 10) = br
End Sub

imroy

凌空一羽 发表于 2017-7-24 23:20
Sub lkyy()
Dim wb As Workbook, Mp$, Mf
Mp = ThisWorkbook.Path & "\"

先谢谢！代码是根据固定行来转置的吧！但如果有些表对应表头的内容不在固定的行，要怎样才能提取？可否根据表头对应名称来查询所在行后再转置？

凌空一羽

imroy 发表于 2017-7-24 23:33
先谢谢！代码是根据固定行来转置的吧！但如果有些表对应表头的内容不在固定的行，要怎样才能提取？可否根 ...

不是吧？假如你细表各行顺序与汇总表的表头一致的话，就没问题，如果不一致的情况的话，就要先判断所在行号再查询了我见你细表好像每张表一致的……

imroy

凌空一羽 发表于 2017-7-24 23:36
不是吧？假如你细表各行顺序与汇总表的表头一致的话，就没问题，如果不一致的情况的话，就要先判断所在行 ...

就是有些明细表排序不一致，有的会在第二项需转置的位置多两三行。

凌空一羽

imroy 发表于 2017-7-24 23:46
就是有些明细表排序不一致，有的会在第二项需转置的位置多两三行。

那改为这样……

Sub lkyy()
Dim wb As Workbook, Mp$, Mf
Range("a2:j1000").ClearContents
Application.ScreenUpdating = False
Mp = ThisWorkbook.Path & "\"
Mf = Dir(Mp & "*.xlsx")
ReDim br(1 To 500, 1 To 10)
Do While Mf <> ""
With Workbooks.Open(Mp & Mf)
    n = n + 1
    ar = .Sheets("Page 1").Range("a1").CurrentRegion
    t = UBound(ar)
    For i = 1 To 10
        tbc = ThisWorkbook.Sheets("汇总表").Cells(1, i).Value
        tr = .Sheets("Page 1").Range("a1:a" & t).Find(tbc, lookat:=xlWhole).Row
        If i < 10 Then
            br(n, i) = ar(tr, 2)
        Else
            For j = 1 To 17
                If j = 1 Then s = ar(j + i, 2) Else s = s & "|" & ar(j + tr, 2)
            Next
            br(n, 10) = s
        End If
    Next
    .Close 0
End With
Mf = Dir()
Loop
Range("a2").Resize(n, 10) = br
Application.ScreenUpdating = True
End Sub

imroy

凌空一羽 发表于 2017-7-24 23:50
那改为这样……

Sub lkyy()

最后一列的提取结果错的。。。而且最后一列并非只提取到40行，有些表的数据可能超过200行。

凌空一羽

imroy 发表于 2017-7-25 08:43
最后一列的提取结果错的。。。而且最后一列并非只提取到40行，有些表的数据可能超过200行。

将代码上的17改为200，你列的例子就是17个，我以为你全部是17个呢……

imroy

凌空一羽 发表于 2017-7-25 10:50
将代码上的17改为200，你列的例子就是17个，我以为你全部是17个呢……

改200后报错，运行错误“9”，下标超界。
就算不改，提取的也不是正确的结果，不改提出来的结果与H列一样。           

imroy

各位高手帮忙瞅瞅！谢谢！