删行

ddz79101

老师！有张表，我希望以其中1列中单元格后部分有数字为条件，删除无数字行。请老师指导。谢谢

cidanji

lisongmei

ykcbf1100

居然不能上传附件，论坛又出问题了

先发个代码吧。

1. Sub ykcbf()  '//2024.3.18
   
2.     Set reg = CreateObject("VBScript.Regexp")
   
3.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Me.[a1].Resize(r, 7)
   
5.     ReDim brr(1 To UBound(arr), 1 To 6)
   
6.     With reg
   
7.         .Global = True
   
8.         .Pattern = "(\d+)"
   
9.         For i = 3 To UBound(arr)
   
10.             s = arr(i, 4)
    
11.             If .test(s) Then
    
12.                 m = m + 1
    
13.                 For j = 2 To UBound(arr, 2)
    
14.                     brr(m, j - 1) = arr(i, j)
    
15.                 Next
    
16.             End If
    
17.         Next
    
18.         Me.[k4:p10000] = ""
    
19.         Me.[k4].Resize(m, 6) = brr
    
20.     End With
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码

ykcbf1100

这个用正则比较准确。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&
   
    Application.ScreenUpdating = False
   
    With [A1].CurrentRegion
        ar = .Value
        For i = UBound(ar) To 1 Step -1
             If IsNumeric(Right(ar(i, 4), 1)) Then
                 .Rows(i).Delete
             End If
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

怎么上传不了附件。。。

swl4561255

1. Sub 删除行()
   
2. Dim myr As Range
   
3. arr = Range("A1:G" & [A1].End(4).Row)
   
4. Set myr = Range("B1:G1")
   
5. For i = 2 To [A1].End(4).Row - 1
   
6.   If arr(i, 4) Like "*[0-9]*" Then
   
7.     Set myr = Union(myr, Range(Cells(i, "B"), Cells(i, "G")))
   
8.   End If
   
9. Next
   
10. myr.Copy [K3]
    
11. End Sub
    

复制代码

ddz79101

ykcbf1100 发表于 2024-3-18 18:42
居然不能上传附件，论坛又出问题了

先发个代码吧。

谢谢老师！出现个提示： r = Me.Cells(Rows.Count, 1).End(3).Row。无效适应关键字

ddz79101

gwjkkkkk 发表于 2024-3-18 18:53
Option Explicit
Sub TEST2()
    Dim ar, i&

谢谢老师！运行成功！