[已解决]关于删除数据的代码求助，在线等，急用

坏也是一种态度

具体需求详见附件
烦请大侠帮忙
在线等，急用

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-23 16:18

定义一下就行。

1. Sub test()
   
2.     Dim r, i, arr
   
3.     Application.ScreenUpdating = False
   
4.     r = ActiveSheet.UsedRange.Rows.Count
   
5.     arr = Range("o1:o" & r)
   
6.     For i = 1 To r
   
7.         If arr(i, 1) = 0 Then arr(i, 1) = ""
   
8.     Next
   
9.     Range("o1:o" & r) = arr
   
10.     Range("o:o").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
11.     Application.ScreenUpdating = True
    
12. End Sub

复制代码

或者不定义，把代码前面的那句 Option Explicit 删掉。

跳转到最佳答案楼层

Hsiao

1. Sub test()
   
2. Dim x
   
3.    For x = [o65500].End(3).Row To 1 Step -1
   
4.         If Cells(x, "o") = 0 Then Rows(x).Delete
   
5.    Next
   
6. End Sub
   

复制代码

江河行地

Sub 删除()
    Dim i As Long
    For i = 2 To Range("o2").End(xlDown).Row
        If Range("O" & i).Value = 0 Then
            Range("O" & i).EntireRow.Delete
        End If
    Next
End Sub

grf1973

数量大的话2楼代码要运行很长时间。

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     r = ActiveSheet.UsedRange.Rows.Count
   
4.     arr = Range("o1:o" & r)
   
5.     For i = 1 To r
   
6.         If arr(i, 1) = 0 Then arr(i, 1) = ""
   
7.     Next
   
8.     Range("o1:o" & r) = arr
   
9.     Range("o:o").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
10.     Application.ScreenUpdating = True
    
11. End Sub

复制代码

坏也是一种态度

grf1973 发表于 2015-9-23 11:38
数量大的话2楼代码要运行很长时间。

大侠为什么我执行的时候提示变量未定义呐，是怎么回事呐

grf1973

定义一下就行。

1. Sub test()
   
2.     Dim r, i, arr
   
3.     Application.ScreenUpdating = False
   
4.     r = ActiveSheet.UsedRange.Rows.Count
   
5.     arr = Range("o1:o" & r)
   
6.     For i = 1 To r
   
7.         If arr(i, 1) = 0 Then arr(i, 1) = ""
   
8.     Next
   
9.     Range("o1:o" & r) = arr
   
10.     Range("o:o").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
11.     Application.ScreenUpdating = True
    
12. End Sub

复制代码

或者不定义，把代码前面的那句 Option Explicit 删掉。

坏也是一种态度

grf1973 发表于 2015-9-23 16:18
定义一下就行。或者不定义，把代码前面的那句 Option Explicit 删掉。

谢谢大侠了，十分感谢大侠
大侠你帮我看下这个提取数据的应该怎么搞
我是菜鸟啊，自己搞不定啊
需要像你们多学习啊

grf1973

附件中“周琦”格式不对，改过来了。另外折扣不知怎么算。

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim brr(1 To 1000, 1 To 12)
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             For Each Sht In wb.Worksheets
    
11.                 n = n + 1
    
12.                 brr(n, 2) = Sht.[b3]      '姓名
    
13.                 brr(n, 5) = Sht.[I4]      '手机号
    
14.                 If Len(Sht.[M3]) > 0 Then brr(n, 5) = Sht.[M3]    '最佳联系方式
    
15.                 brr(n, 7) = Sht.[d3]      '生日
    
16.                 arr = Sht.Range("a19:i30")
    
17.                 For i = 2 To UBound(arr)
    
18.                     If Len(arr(i, 1)) = 0 Then arr(i, 1) = arr(i - 1, 1)
    
19.                     jf = arr(i, 8)     '积分
    
20.                     If jf > 0 Then
    
21.                         nf = Left(arr(i, 1), 4)      '年
    
22.                         If nf = "2015" Then brr(n, 8) = brr(n, 8) + jf     '2015年积分
    
23.                         If nf = "2014" Then brr(n, 9) = brr(n, 9) + jf     '2014年积分
    
24.                     End If
    
25.                 Next
    
26.             Next
    
27.             wb.Close False
    
28.         End If
    
29.         Filename = Dir
    
30.     Loop
    
31.     Set Sht = Nothing
    
32.     r = [b65536].End(3).Row + 1
    
33.     If n > 0 Then Cells(r, 1).Resize(n, 12) = brr
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

坏也是一种态度

grf1973 发表于 2015-9-24 14:23
附件中“周琦”格式不对，改过来了。另外折扣不知怎么算。

十分感谢大侠了，大侠，这里面标黄部分的籍贯和备注没有提取么
？？？

坏也是一种态度

grf1973 发表于 2015-9-24 14:23
附件中“周琦”格式不对，改过来了。另外折扣不知怎么算。

大侠我在文件里执行的时候为什么有许多表提示类型不匹配呀，是什么原因