[已解决]去字母

hwc2ycy

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 = arr
    
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. 
    
50. End Sub

复制代码

张雄友

hwc2ycy 发表于 2013-6-17 21:48

选中后执行宏，无法实现。

hwc2ycy

    If TypeName(Selection) > "Range" Then
这名有问题，我可能打落了。
应该是<>

hwc2ycy

Selection.Areas(k).Value = arr

这句也写误了，应该是 result

hwc2ycy

不好意思，我这没测。

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 发表于 2013-6-17 22:03
不好意思，我这没测。

Selection.NumberFormatLocal = "@"

加多这句就更好了，因为不设置为文本格式，0就不见了。

hwc2ycy

恩，这个有道理，我习惯是加'，不修改单元格格式。