把多表格相同位置单元格汇总到一张新的工作表中

xiangbaoan

wangrh 发表于 2021-1-17 21:01
感谢xiangbaoan老师，现在才看到您的回复，完美解决

万恶的审核，居然有3个多小时！

yellowhawk

我来凑个热闹，代码写得比较笨，希望对你有用。
Sub aa()
Dim sh As Sheets
Dim arr(), brr(), crr
Dim a, b, n
    n = 1
    For i = 1 To Sheets.Count
      If Sheets(i).Tab.ColorIndex = 5 Then
    ReDim Preserve arr(1 To n)
    arr(n) = Sheets(i).Name
    n = n + 1
    End If
    Next
    n1 = 1
For Each m In arr
  r = Sheets(m).Range("O65536").End(xlUp).Row - 37
ReDim Preserve brr(1 To 5, 1 To r1 + r)
   For a1 = 1 To r
   brr(1, r1 + a1) = arr(n1)
    For m1 = 2 To 5
     brr(m1, r1 + a1) = Sheets(m).Range("O38").Offset(a1 - 1, m1 - 2)
    Next m1
   Next a1
r1 = r1 + r
n1 = n1 + 1
Next
Sheets("玻璃汇总").Range("A3:E10000").Clear
Sheets("玻璃汇总").Range("A3:E" & UBound(brr, 2) + 2) = Application.Transpose(brr)
'后面加格子什么的就自己套用代码即可'
End Sub

wangrh

yellowhawk 发表于 2021-1-20 00:04
我来凑个热闹，代码写得比较笨，希望对你有用。
Sub aa()
Dim sh As Sheets

感谢

3822

看下这个行不行

wangrh

3822 发表于 2023-7-4 16:23
看下这个行不行

完美，感谢@3822