复制工作薄中所有工作表第二行到新增的工作表

38180203

WPS: 复制所有工作薄中所有工作表第二行到新增的工作表,,标题栏一样也复制过去.


多次点击运行代码数据不会叠加


非常感谢老师!!

小凡、、、

quqiyuan

参与一下，供参考。。。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.25
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总")
   
4.     ReDim brr(1 To 10000, 1 To 8)
   
5.     On Error Resume Next
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             n = n + 1
   
9.             With sht
   
10.                 arr = .UsedRange
    
11.                 If n = 1 Then
    
12.                     m = m + 1
    
13.                     For j = 1 To UBound(arr, 2)
    
14.                         brr(m, j) = arr(1, j)
    
15.                     Next
    
16.                     brr(m, 8) = "客户"
    
17.                 End If
    
18.                 m = m + 1
    
19.                 For j = 1 To UBound(arr, 2)
    
20.                     brr(m, j) = arr(2, j)
    
21.                 Next
    
22.                 brr(m, 8) = .Name
    
23.             End With
    
24.         End If
    
25.     Next
    
26.     With sh
    
27.         .UsedRange.Offset(1).Clear
    
28.         With .[a1].Resize(m, 8)
    
29.             .Value = brr
    
30.             .Borders.LineStyle = 1
    
31.             .HorizontalAlignment = xlCenter
    
32.             .VerticalAlignment = xlCenter
    
33.         End With
    
34.     End With
    
35.     Application.ScreenUpdating = False
    
36.     MsgBox "OK！"
    
37. End Sub
    
38. 
    

复制代码

38180203

quqiyuan 发表于 2024-7-25 19:44
参与一下，供参考。。。

感谢老师...非常的完美, 小花晚点一定送上