[已解决]去字母

张雄友

把所有字母去掉。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-17 22:03

不好意思，我这没测。

1. Sub 方法3()
   
2. 
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim arr(), result()
   
5. 
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.EnableEvents = False
   
9.     Application.Calculation = xlCalculationManual
   
10. 
    
11. 
    
12.     If TypeName(Selection) <> "Range" Then
    
13.         MsgBox "所选对象非单元格"
    
14.         GoTo Quit
    
15.     End If
    
16.     Dim objRegExp As Object
    
17.     Set objRegExp = CreateObject("VBScript.regExp")
    
18.     With objRegExp
    
19.         .Global = True
    
20.         .Pattern = "[a-z,A-Z]"
    
21. 
    
22.         For k = 1 To Selection.Areas.Count
    
23.             '防止区域只有一个单元格，这样赋值就不存在数组一说了。
    
24.             If Selection.Areas(k).Count = 1 Then
    
25.                 Selection.Areas(k).Value = .Replace(Selection.Areas(k).Value, "")
    
26.             Else
    
27.                 arr = Selection.Areas(k).Value
    
28.                 ReDim result(1 To UBound(arr), 1 To UBound(arr, 2))
    
29.                 For i = LBound(arr) To UBound(arr)
    
30.                     For j = LBound(arr, 2) To UBound(arr, 2)
    
31.                         If .test(arr(i, j)) Then
    
32.                             result(i, j) = .Replace(arr(i, j), "")
    
33.                         Else
    
34.                             result(i, j) = arr(i, j)
    
35.                         End If
    
36.                     Next
    
37.                 Next
    
38.                 Selection.Areas(k).Value = result
    
39.             End If
    
40.         Next
    
41.     End With
    
42.     MsgBox "OK"
    
43. 
    
44. Quit:
    
45.     Application.ScreenUpdating = True
    
46.     Application.DisplayAlerts = True
    
47.     Application.EnableEvents = True
    
48.     Application.Calculation = xlCalculationAutomatic
    
49. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Function rp(rg) As String
   
2.     Dim objRegExp As Object
   
3.    
   
4.     Set objRegExp = CreateObject("VBScript.regExp")
   
5.     rp = rg
   
6.     With objRegExp
   
7.         .Global = True
   
8.         .Pattern = "[a-z,A-Z]"
   
9.             If .test(rg) Then
   
10.                 rp = .Replace(rg, "")
    
11.             End If
    
12.     End With
    
13.     Set objRegExp = Nothing
    
14. End Function

复制代码

hwc2ycy

直接在单元内用函数也可以=RP(A2)

xdd_sky

看看是否符合你的要求。。。

hwc2ycy

1. Sub 方法2()
   
2.     Dim lLastRow&
   
3.     Dim i As Long
   
4.     Dim arr(), result()
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.EnableEvents = False
   
9.     Application.Calculation = xlCalculationManual
   
10.    
    
11.    
    
12.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
13.     arr = Range("a2:b" & lLastRow).Value
    
14.     ReDim result(1 To UBound(arr), 1 To 1)
    
15. 
    
16.     Dim objRegExp As Object
    
17.     Set objRegExp = CreateObject("VBScript.regExp")
    
18.     With objRegExp
    
19.         .Global = True
    
20.         .Pattern = "[a-z,A-Z]"
    
21.         For i = LBound(arr) To UBound(arr)
    
22.             If .test(arr(i, 1)) Then
    
23.                 result(i, 1) = .Replace(arr(i, 1), "")
    
24.             Else
    
25.                 result(i, 1) = arr(i, 1)
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Range("f2").Resize(UBound(arr)).Value = result
    
30.     Application.ScreenUpdating = True
    
31.     Application.DisplayAlerts = True
    
32.     Application.EnableEvents = True
    
33.     Application.Calculation = xlCalculationAutomatic
    
34.     MsgBox "OK"
    
35. End Sub

复制代码

hwc2ycy

1. Sub 方法2()
   
2.     Dim lLastRow&
   
3.     Dim i As Long
   
4.     Dim arr(), result()
   
5.    
   
6.     '关闭屏幕更新，显示警告，事件，手动计算
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     Application.EnableEvents = False
   
10.     Application.Calculation = xlCalculationManual
    
11.    
    
12.    
    
13.     '取A列数据到数组
    
14.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
15.     arr = Range("a2:b" & lLastRow).Value
    
16.     ReDim result(1 To UBound(arr), 1 To 1)
    
17. 
    
18.     '正则处理
    
19.     Dim objRegExp As Object
    
20.     Set objRegExp = CreateObject("VBScript.regExp")
    
21.     With objRegExp
    
22.         .Global = True
    
23.         '匹配规则为字母
    
24.         .Pattern = "[a-z,A-Z]"
    
25.         For i = LBound(arr) To UBound(arr)
    
26.             If .test(arr(i, 1)) Then
    
27.                 '替换字母
    
28.                 result(i, 1) = .Replace(arr(i, 1), "")
    
29.             Else
    
30.                 result(i, 1) = arr(i, 1)
    
31.             End If
    
32.         Next
    
33.     End With
    
34.     Set objRegExp = Nothing
    
35.    
    
36.     '对之前关闭的属性进行恢复打开
    
37.     Range("f2").Resize(UBound(arr)).Value = result
    
38.     Application.ScreenUpdating = True
    
39.     Application.DisplayAlerts = True
    
40.     Application.EnableEvents = True
    
41.     Application.Calculation = xlCalculationAutomatic
    
42.     MsgBox "OK"
    
43. End Sub

复制代码

张雄友

hwc2ycy 发表于 2013-6-17 19:08

首先谢谢，但是如果数据有多个区域且区域不连续，我改用Selection属性，就是选中后执行，为什么不能，看看哪里改错了？

1. Sub 方法2()
   
2.     Dim lLastRow&
   
3.     Dim i As Long
   
4.     Dim arr(), result()
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.EnableEvents = False
   
9.     Application.Calculation = xlCalculationManual
   
10.    
    
11.    
    
12.     lLastRow = Cells(Rows.Count, Columns.Count).End(xlUp).Row
    
13.     arr = Selection
    
14.     ReDim result(1 To UBound(arr), 1 To Columns.Count)
    
15. 
    
16.     Dim objRegExp As Object
    
17.     Set objRegExp = CreateObject("VBScript.regExp")
    
18.     With objRegExp
    
19.         .Global = True
    
20.         .Pattern = "[a-z,A-Z]"
    
21.         For i = LBound(arr) To UBound(arr)
    
22.             If .test(arr(i, Columns.Count)) Then
    
23.                 result(i, Columns.Count) = .Replace(arr(i, Columns.Count), "")
    
24.             Else
    
25.                 result(i, Columns.Count) = arr(i, Columns.Count)
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Selection.Resize(UBound(arr)).Value = result
    
30.     Application.ScreenUpdating = True
    
31.     Application.DisplayAlerts = True
    
32.     Application.EnableEvents = True
    
33.     Application.Calculation = xlCalculationAutomatic
    
34.     MsgBox "OK"
    
35. End Sub
    

复制代码

hwc2ycy

1. Sub 方法2()
   
2. 
   
3.     Dim rg As Range
   
4.     Dim objRegExp As Object
   
5. 
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.EnableEvents = False
   
9.     Application.Calculation = xlCalculationManual
   
10. 
    
11.     If TypeName(Selection) > "Range" Then
    
12.         MsgBox "所选对象非单元格"
    
13.         GoTo Quit
    
14.     End If
    
15. 
    
16.     Set objRegExp = CreateObject("VBScript.regExp")
    
17.     With objRegExp
    
18.         .Global = True
    
19.         .Pattern = "[a-z,A-Z]"
    
20.         For Each rg In Selection
    
21.             If .test(rg.Value) Then rg.Value = .Replace(rg.Value, "")
    
22.         Next
    
23.     End With
    
24.     MsgBox "OK"
    
25. Quit:
    
26.     Application.ScreenUpdating = True
    
27.     Application.DisplayAlerts = True
    
28.     Application.EnableEvents = True
    
29.     Application.Calculation = xlCalculationAutomatic
    
30. 
    
31. End Sub

复制代码

hwc2ycy

如果是多区域，你想用数组的话，就得用Selection.areas来做处理。
多区域对象有，直接用SELECTION.VALUE只会是区域1赋值给数组。

张雄友

hwc2ycy 发表于 2013-6-17 21:29
如果是多区域，你想用数组的话，就得用Selection.areas来做处理。
多区域对象有，直接用SELECTION.VALUE只 ...

怎么改才对？请明示？