复制表且涂色

ddz79101

老师！复制2表另存到1表，且其中1表涂色，请老师帮忙，谢谢

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.17
   
2.     Dim arr, brr(1 To 10000, 1 To 13)
   
3.     Set ws = ThisWorkbook
   
4.     Set sh = ws.Sheets("汇总")
   
5.     With sh
   
6.         .UsedRange.Offset(1).Clear
   
7.         .Cells.Interior.ColorIndex = 0
   
8.     End With
   
9.     For Each sht In Sheets
   
10.         If InStr(sht.Name, "年级") Then
    
11.             With sht
    
12.                 r = sh.Cells(Rows.Count, 1).End(3).Offset(1).Row
    
13.                 r1 = .UsedRange.Find("合计").Row
    
14.                 arr = .Range("a2:m" & r1 - 1)
    
15.                 sh.Cells(r, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
16.                 If InStr(arr(1, 1), "一年") Then
    
17.                     sh.Cells(r, 1).Resize(UBound(arr), UBound(arr, 2)).Interior.ColorIndex = 8
    
18.                 End If
    
19.                 sh.Cells(r, 1).Resize(UBound(arr), UBound(arr, 2)).Borders.LineStyle = 1
    
20.             End With
    
21.         End If
    
22.     Next
    
23. End Sub
    

复制代码

清风竹-

请看附件。

sxbjzjf110

参与一下。。。。。

ddz79101

sxbjzjf110 发表于 2024-2-17 17:20
参与一下。。。。。

谢谢老师！目标实现

ddz79101

清风竹- 发表于 2024-2-17 16:47
请看附件。

谢谢老师！目标实现

ddz79101

ykcbf1100 发表于 2024-2-17 16:46
附件供参考。。。

谢谢老师！目标实现