批量提取多个分表的A列非空数据

njwtg

工作簿中工作表名称为“表？”（？为纯阿拉伯数字，如表1、表2、表3、表4.......表30，有1~30），还有其他表
从第3行开始，需要将“表？”中的A列非空的单元格数据，提取到“数据表“的Y列。并将“表？”中A2数据提取到“数据表“的X列。在“数据表“中判断顺序号
颜色单元格中的数据是程序运行后的效果，实际程序运行后是不标色的
谢谢老师！

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.19
   
2.     Dim brr(1 To 1000, 1 To 3)
   
3.     For Each sht In Sheets
   
4.         If Left(sht.Name, 1) = "表" Then
   
5.             With sht
   
6.                 If .UsedRange.Count > 10 Then
   
7.                     r = .Cells(Rows.Count, 1).End(3).Row
   
8.                     arr = .Range("a4:a" & r)
   
9.                     n = 0
   
10.                     For i = 1 To UBound(arr)
    
11.                         If arr(i, 1) <> Empty Then
    
12.                             m = m + 1: n = n + 1
    
13.                             brr(m, 1) = .[a2]
    
14.                             brr(m, 2) = arr(i, 1)
    
15.                             brr(m, 3) = n
    
16.                         End If
    
17.                     Next
    
18.                 End If
    
19.             End With
    
20.         End If
    
21.     Next
    
22.     With Sheets("数据表")
    
23.       .[x:z] = ""
    
24.       .[x1].Resize(m, 3) = brr
    
25.     End With
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

njwtg

ok，谢谢
ykcbf1100老师！