求一个复制粘贴的VBA代码

ykcbf1100

代码如下：

1. Sub ykcbf()    '//2024.2.27
   
2.     Dim arr, brr(1 To 10000, 1 To 3)
   
3.     With Sheets("表1")
   
4.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
5.         arr = .Range("a1:at" & r)
   
6.     End With
   
7.     For j = 4 To UBound(arr, 2)
   
8.         For i = 4 To UBound(arr)
   
9.             If arr(i, j) <> Empty Then
   
10.                 m = m + 1
    
11.                 brr(m, 1) = arr(i, 1)
    
12.                 brr(m, 2) = arr(i, 2)
    
13.                 brr(m, 3) = arr(3, j)
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     With Sheets("表2")
    
18.        .UsedRange.Offset(1) = ""
    
19.        .[a2].Resize(m, 3) = brr
    
20.     End With
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码

zzq0117

quqiyuan 发表于 2024-2-27 21:24
楼上兄弟的代码：

谢谢老师成功了，太谢谢了。

zzq0117

ykcbf1100 发表于 2024-2-27 22:11
附件供参考。。。

谢谢老师。