作品分享：批量剔除空格

little-key

代码如下：

1. Sub 批量剔除空格()    '批量剔除空格，可以是区域，也可以是单列或者多列
   
2.     On Error Resume Next
   
3.     Application.ScreenUpdating = False
   
4.     Dim n As Long, i As Long, arr, t As Single, q
   
5.     If Selection.Count = 1 Then MsgBox "您只选择了一个单元格，太 Easy 了" & vbCrLf & "请自行手动删除。", 48 + vbOKOnly, "警示": Exit Sub
   
6.     ans = Application.InputBox("请选择剔除全部、左边还是右边。" & Chr(10) & "1：剔除全部空格；" & Chr(10) & "2：剔除左边空格。" & Chr(10) & "3：剔除右边空格。", "剔除方式", 1, 100, 100, , , 1)
   
7.     If ans = False Then Exit Sub
   
8.     t = Timer
   
9.     PG = Selection.Cells(1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)  '定义选区第一个单元格的地址
   
10.     y = Selection.Rows.Count  '定义选区的行数
    
11.     ph = Selection.Columns.Count     '定义选区列数
    
12.     Pl = Selection.Column  '定义选区第一类的列标
    
13.     q = Columns(1).Rows.Count   '判断是07格式还是非07格式，若为07格式，则q=1048576，否则为65536
    
14.     Select Case ans
    
15.     Case 1    '剔除全部空格
    
16.         For k = 1 To ph   '以循环执行剔除空格的模式执行
    
17.             '+++++++++++核心部分(S)+++++++++++
    
18.             n = WorksheetFunction.Min(Cells(q, Pl + k - 1).End(xlUp).Row, y)
    
19.             arr = Range(PG).Offset(0, k - 1).Resize(n, 1)
    
20.             With CreateObject("scripting.dictionary")    '建立字典
    
21.                 For i = 1 To n
    
22.                     .add i, Trim(arr(i, 1))    '顺序建立字典内容
    
23.                 Next
    
24.                 arrk = Range(PG).Offset(0, k - 1).Resize(n, 1)
    
25.                 For i = 1 To UBound(arr)
    
26.                     arr(i, 1) = .item(i)   '在字典中按key取item
    
27.                 Next
    
28.             End With
    
29.             Range(PG).Offset(0, k - 1).Resize(UBound(arr), 1) = arr
    
30.             '+++++++++++核心部分(E)+++++++++++
    
31.         Next k
    
32. 
    
33.         Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
    
34.                           SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    
35.                           ReplaceFormat:=False
    
36. 
    
37.     Case 2  '剔除左边空格
    
38.         For k = 1 To ph   '以循环执行剔除空格的模式执行
    
39.             '+++++++++++核心部分(S)+++++++++++
    
40.             n = WorksheetFunction.Min(Cells(q, Pl + k - 1).End(xlUp).Row, y)
    
41.             arr = Range(PG).Offset(0, k - 1).Resize(n, 1)
    
42.             With CreateObject("scripting.dictionary")    '建立字典
    
43.                 For i = 1 To n
    
44.                     .add i, LTrim(arr(i, 1))    '顺序建立字典内容
    
45.                 Next
    
46.                 arrk = Range(PG).Offset(0, k - 1).Resize(n, 1)
    
47.                 For i = 1 To UBound(arr)
    
48.                     arr(i, 1) = .item(i)   '在字典中按key取item
    
49.                 Next
    
50.             End With
    
51.             Range(PG).Offset(0, k - 1).Resize(UBound(arr), 1) = arr
    
52.             '+++++++++++核心部分(E)+++++++++++
    
53.         Next k
    
54.     Case 3    '剔除右边
    
55.         For k = 1 To ph   '以循环执行剔除空格的模式执行
    
56.             '+++++++++++核心部分(S)+++++++++++
    
57.             n = WorksheetFunction.Min(Cells(q, Pl + k - 1).End(xlUp).Row, y)
    
58.             arr = Range(PG).Offset(0, k - 1).Resize(n, 1)
    
59.             With CreateObject("scripting.dictionary")    '建立字典
    
60.                 For i = 1 To n
    
61.                     .add i, RTrim(arr(i, 1))    '顺序建立字典内容
    
62.                 Next
    
63.                 arrk = Range(PG).Offset(0, k - 1).Resize(n, 1)
    
64.                 For i = 1 To UBound(arr)
    
65.                     arr(i, 1) = .item(i)   '在字典中按key取item
    
66.                 Next
    
67.             End With
    
68.             Range(PG).Offset(0, k - 1).Resize(UBound(arr), 1) = arr
    
69.             '+++++++++++核心部分(E)+++++++++++
    
70.         Next k
    
71.     End Select
    
72.     Application.ScreenUpdating = True
    
73.     MsgBox "替换完毕" & vbCrLf & "用时共计 " & Timer - t & " 秒!", 64 + vbOKOnly, "友情提示"    '速度还可以
    
74. End Sub

复制代码

速度还算可以，以前问过很多人，后来自己使用字典开发，提高了速度，只是还是比较繁琐。

LangQueS

终于出炉了！

little-key

由于目前都是使用Office 2007，考虑到目前很多会员都是使用Office 2003版本，因此只提供代码，需要的会员可以利用代码整合到自己的模板中，作为自己的一项工具，希望它可以提高您的工作效率。

LangQueS

相关参考：

如何替换掉“假空”单元为真空        http://club.excelhome.net/dispbb ... replyID=&skin=0

dsp5000

多谢分享。

little-key

其实这个解决我先前想的一个问题：如孙版说的假空，或者是特殊的空格，这种情况在从数据库中直接导出的数据比较常见：http://club.excelhome.net/thread-436992-1-1.html

[ 本帖最后由 little-key 于 2009-7-13 21:19 编辑 ]

zldccmx

呵呵，使用字典方法来剔除空格不敢苟同

zldccmx

对于替换全部空格，一条语句足矣，就是版主在CASE1中的最后一行
整个Case 1 就可以修改如下，字典、数组 以及循环都是冗余的
case 1: Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart

little-key

Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart这个只是其中一种情况，当是非标准的空格时，这句代码就无法起到作用了。

laoyebin

trim并不能去除全部的假空字符