[已解决]如何通过删除操作，只保留每一张工作表的最后10行数据

leobu

有问题请教大家：如图所示，现在有一个工作簿含有若干张工作表，除了sheet1工作表以外，其他的工作表命名没有规则，并且其他工作表所包含的数据行数并不一致。
请问：怎样通过VBA编程，将除了sheet1以外的每一张工作表的第一行和最后10行数据保留下来，而将其他行一并删去。

最佳答案

月排行榜 / 总排行榜

芐雨

2015-1-15 08:49

1. Sub test()
   
2.     Application.ScreenUpdating = False    '禁刷新
   
3.     Dim sh As Worksheet
   
4.     For Each sh In Worksheets         '遍历工作表
   
5.         If sh.Name <> "sheet1" Then     '不等于sheet1
   
6.             rw = sh.Cells(Rows.Count, 1).End(3).Row    '最大行数
   
7.             If rw > 11 Then                        '行数大于11
   
8.                 sh.Rows("2:" & (rw - 10)).Delete  '第2行到倒数第11行删除
   
9.             End If
   
10.         End If
    
11.     Next
    
12.     MsgBox "数据删除完毕！", , "提示"
    
13.     Application.ScreenUpdating = True         '刷新
    
14. End Sub

复制代码

跳转到最佳答案楼层

1091126096

1. Sub text()
   
2. Dim i, N
   
3. N = Range("A65536").End(xlUp).Row
   
4. For i = N - 10 To 2 Step -1
   
5. Rows(i).Delete
   
6. Next
   
7. End Sub

复制代码

爱疯

Sub test()
    Dim r&
    On Error Resume Next
    r = Cells(Rows.Count, 1).End(xlUp).Row
    Rows((r - 10) & ":" & r).ClearContents '不足10行时，不执行
End Sub

ppp710715

1. Sub test()
   
2.     Dim sh As Worksheet
   
3.     For Each sh In Worksheets
   
4.         If sh.Name <> "sheet1" Then
   
5.           rw = sh.Cells(Rows.Count, 1).End(3).Row
   
6.           If rw > 11 Then
   
7.           For i = rw - 10 To 2 Step -1
   
8.            sh.Rows(i).Delete
   
9.           Next
   
10.           End If
    
11.         End If
    
12.     Next
    
13.      MsgBox "数据删除完毕！", , "提示"
    
14. End Sub
    

复制代码

芐雨

1. Sub test()
   
2.     Application.ScreenUpdating = False    '禁刷新
   
3.     Dim sh As Worksheet
   
4.     For Each sh In Worksheets         '遍历工作表
   
5.         If sh.Name <> "sheet1" Then     '不等于sheet1
   
6.             rw = sh.Cells(Rows.Count, 1).End(3).Row    '最大行数
   
7.             If rw > 11 Then                        '行数大于11
   
8.                 sh.Rows("2:" & (rw - 10)).Delete  '第2行到倒数第11行删除
   
9.             End If
   
10.         End If
    
11.     Next
    
12.     MsgBox "数据删除完毕！", , "提示"
    
13.     Application.ScreenUpdating = True         '刷新
    
14. End Sub

复制代码

hyjking618

Sub test()
    Dim r&
    On Error Resume Next
    r = Cells(Rows.Count, 1).End(xlUp).Row
    Rows((r - 10) & ":" & r).ClearContents '不足10行时，不执行
End Sub
你可以试试

leobu

感谢诸位高手的热情相助，问题解决了，谢谢大家。