楼主
little-key |
代码如下：- Sub 批量剔除空格() '批量剔除空格，可以是区域，也可以是单列或者多列
- On Error Resume Next
- Application.ScreenUpdating = False
- Dim n As Long, i As Long, arr, t As Single, q
- If Selection.Count = 1 Then MsgBox "您只选择了一个单元格，太 Easy 了" & vbCrLf & "请自行手动删除。", 48 + vbOKOnly, "警示": Exit Sub
- ans = Application.InputBox("请选择剔除全部、左边还是右边。" & Chr(10) & "1：剔除全部空格；" & Chr(10) & "2：剔除左边空格。" & Chr(10) & "3：剔除右边空格。", "剔除方式", 1, 100, 100, , , 1)
- If ans = False Then Exit Sub
- t = Timer
- PG = Selection.Cells(1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) '定义选区第一个单元格的地址
- y = Selection.Rows.Count '定义选区的行数
- ph = Selection.Columns.Count '定义选区列数
- Pl = Selection.Column '定义选区第一类的列标
- q = Columns(1).Rows.Count '判断是07格式还是非07格式，若为07格式，则q=1048576，否则为65536
- Select Case ans
- Case 1 '剔除全部空格
- For k = 1 To ph '以循环执行剔除空格的模式执行
- '+++++++++++核心部分(S)+++++++++++
- n = WorksheetFunction.Min(Cells(q, Pl + k - 1).End(xlUp).Row, y)
- arr = Range(PG).Offset(0, k - 1).Resize(n, 1)
- With CreateObject("scripting.dictionary") '建立字典
- For i = 1 To n
- .add i, Trim(arr(i, 1)) '顺序建立字典内容
- Next
- arrk = Range(PG).Offset(0, k - 1).Resize(n, 1)
- For i = 1 To UBound(arr)
- arr(i, 1) = .item(i) '在字典中按key取item
- Next
- End With
- Range(PG).Offset(0, k - 1).Resize(UBound(arr), 1) = arr
- '+++++++++++核心部分(E)+++++++++++
- Next k
- Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
- SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
- ReplaceFormat:=False
- Case 2 '剔除左边空格
- For k = 1 To ph '以循环执行剔除空格的模式执行
- '+++++++++++核心部分(S)+++++++++++
- n = WorksheetFunction.Min(Cells(q, Pl + k - 1).End(xlUp).Row, y)
- arr = Range(PG).Offset(0, k - 1).Resize(n, 1)
- With CreateObject("scripting.dictionary") '建立字典
- For i = 1 To n
- .add i, LTrim(arr(i, 1)) '顺序建立字典内容
- Next
- arrk = Range(PG).Offset(0, k - 1).Resize(n, 1)
- For i = 1 To UBound(arr)
- arr(i, 1) = .item(i) '在字典中按key取item
- Next
- End With
- Range(PG).Offset(0, k - 1).Resize(UBound(arr), 1) = arr
- '+++++++++++核心部分(E)+++++++++++
- Next k
- Case 3 '剔除右边
- For k = 1 To ph '以循环执行剔除空格的模式执行
- '+++++++++++核心部分(S)+++++++++++
- n = WorksheetFunction.Min(Cells(q, Pl + k - 1).End(xlUp).Row, y)
- arr = Range(PG).Offset(0, k - 1).Resize(n, 1)
- With CreateObject("scripting.dictionary") '建立字典
- For i = 1 To n
- .add i, RTrim(arr(i, 1)) '顺序建立字典内容
- Next
- arrk = Range(PG).Offset(0, k - 1).Resize(n, 1)
- For i = 1 To UBound(arr)
- arr(i, 1) = .item(i) '在字典中按key取item
- Next
- End With
- Range(PG).Offset(0, k - 1).Resize(UBound(arr), 1) = arr
- '+++++++++++核心部分(E)+++++++++++
- Next k
- End Select
- Application.ScreenUpdating = True
- MsgBox "替换完毕" & vbCrLf & "用时共计 " & Timer - t & " 秒!", 64 + vbOKOnly, "友情提示" '速度还可以
- End Sub
速度还算可以，以前问过很多人，后来自己使用字典开发，提高了速度，只是还是比较繁琐。 |
Book2.rar