历遍工作表排序与插入的问题

杨小妹

附件 历遍工作表排序与插入附件.rar (1004.52 KB, 下载次数: 9)

2024-7-24 10:39 上传

点击文件名下载附件

谢谢老师！

longwin

Sub test()
    '按B列排序
    For Each sh In Sheets
        Set Rng = sh.[a1].CurrentRegion
        Rng.Sort key1:=sh.Range("B1:B" & sh.[b1].End(xlDown).Row), Header:=xlNo
    Next
    Set sh0 = Sheets("Sheet0")
    '插入数据
    For Each sh In Sheets
        If sh.Name <> "Sheet0" Then
            sh0.Range("A1:C" & sh0.[a1].End(xlDown).Row).Copy sh.Range("F1:H" & sh0.[a1].End(xlDown).Row)
        End If
    Next
    MsgBox "OK!"
   
End Sub

半百

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.24
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("Sheet0")
   
4.     With sh
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 3)
   
7.     End With
   
8.     On Error Resume Next
   
9.     For Each sht In Sheets
   
10.         If sht.Name <> sh.Name Then
    
11.             With sht
    
12.                 .[d1:z100000] = ""
    
13.                 r = .Cells(Rows.Count, 1).End(3).Row
    
14.                 Set Rng = .[a1].Resize(r, 4)
    
15.                 Rng.Sort .[b1], 1
    
16.                 .[f1].Resize(UBound(arr), 3) = arr
    
17.             End With
    
18.         End If
    
19.     Next
    
20.     Application.ScreenUpdating = True
    
21.     MsgBox "OK！"
    
22. End Sub
    
23. 
    

复制代码