汇总 需要批量多薄 一表 固定区域

fengyunjay2004

汇总 需要批量多薄 生成一表， 固定区域    详见 附件  汇总excel文件是我想要这样的   急着要  谢谢大家  本人是小白

ykcbf1100

附件请参考。。。

3190496160

Sub 合并()
Application.ScreenUpdating = False '/
Dim ar As Variant
Dim arr()
Dim rn As Range
ReDim arr(1 To 10000, 1 To 3)
With Sheets("汇总")
    mc = .[b1] & ""
    f = Dir(ThisWorkbook.Path & "\*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
            wj = Split(wb.Name, ".")(0)
            With wb.Worksheets(mc)
                Set rn = .Columns("b:e").Find("质量控制资料", , , , , , 1)
                If rn Is Nothing Then MsgBox "缺少质量控制资料暴击字段！": End
                r = rn.Row - 1
                ar = .Range("b7:e" & r)
            End With
            wb.Close False
            For I = 2 To UBound(ar)
                If Trim(ar(I, 2)) <> "" Then
                    n = n + 1
                    arr(n, 1) = wj
                    arr(n, 2) = n
                    arr(n, 3) = ar(I, 2)
                End If
            Next I
        End If
    f = Dir
    Loop
    If n = "" Then MsgBox "没有需要汇总的数据！": End
    .UsedRange.Offset(4).Clear
    .[a5].Resize(n, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True '/
MsgBox "ok!"
End Sub

3190496160

3190496160

汇总附件.rar (61.82 KB, 下载次数: 12)

2023-3-14 11:17 上传

点击文件名下载附件

cjc209

搞定                          

风过天涯

ykcbf1100 发表于 2023-3-14 11:15
附件请参考。。。

草爷，我就不另外开贴了，比如说我希望arr（i，3）和arr（i，6）都对应写进brr（m，4）这一列，可以做到吗

ykcbf1100

风过天涯 发表于 2023-3-14 15:18
草爷，我就不另外开贴了，比如说我希望arr（i，3）和arr（i，6）都对应写进brr（m，4）这一列，可以做到 ...

brr(m,4)=arr(i,3)&arr(i,6)

风过天涯

ykcbf1100 发表于 2023-3-14 15:28
brr(m,4)=arr(i,3)&arr(i,6)

谢谢草爷，我没记错的话，这样好像是两列合一列，而我要的是第三列赋值完了继续赋值第六列，有没有什么方法

ykcbf1100

风过天涯 发表于 2023-3-14 15:35
谢谢草爷，我没记错的话，这样好像是两列合一列，而我要的是第三列赋值完了继续赋值第六列，有没有什么方 ...

不懂你的意思