Option Explicit
Sub test()
Dim Arr, i, x, T, j$, c
Arr = Range([A1], [A65536].End(3))
For i = 1 To UBound(Arr)
j = Trim(Arr(i, 1))
c = Len(j)
For x = c To 2 Step -1
If UCase(Mid(j, x, 1)) Like "[A-Z]" Then
j = Trim(Mid(j, 1, x - 1)) & " " & Mid(j, x, c * 2)
End If
Next
Arr(i, 1) = j
Next
[B1].Resize(UBound(Arr), 1) = Arr
End Sub作者: samwang 時間: 2022-8-24 18:30
Sub test()
Dim Arr, i, x, T, j$, c
Arr = Range([A1], [A65536].End(3))
For i = 1 To UBound(Arr)
j = Trim(Arr(i, 1))
c = Len(j)
For x = c To 2 Step -1
T = UCase(Mid(j, x, 1))
If Asc(T) > 64 And Asc(T) < 123 Then
Arr(i, 1) = Replace(Arr(i, 1), T, " " & T)
End If
Next
Next
[B1].Resize(UBound(Arr), 1) = Arr
End Sub作者: s13030029 時間: 2022-8-25 08:37
Option Explicit
Sub test4() '單列或多列都可以用
Dim Arr, i, x, j$, c, d, xD, T
Arr = Range([A1], [A65536].End(3).Offset(1, 0))
Set xD = CreateObject("Scripting.Dictionary")
For d = 65 To 122 '65~90是大寫 97~122是小寫
xD(d) = Chr(d)
If d = 90 Then d = 96
Next
T = Join(xD.items, "//")
For i = 1 To UBound(Arr) - 1
j = Arr(i, 1)
j = Replace(Replace(j, " ", ""), " ", "") '去除空白字元
c = Len(j)
For x = c To 2 Step -1
If InStr(T, Mid(j, x, 1)) And Mid(j, x - 1, 1) <> vbLf Then
j = Mid(j, 1, x - 1) & " " & Mid(j, x, c * 2)
End If
Next
Arr(i, 1) = j
Next
[B1].Resize(UBound(Arr) - 1, 1) = Arr
Set Arr = Nothing
End Sub作者: s13030029 時間: 2022-8-25 14:25
請再測試看看,謝謝
Sub test()
Dim Arr, a, T, i&, x, j%
Arr = Range([A1], [A65536].End(3).Offset(1, 0))
For i = 1 To UBound(Arr) - 1
a = Split(Trim(Arr(i, 1)), Chr(10))
For x = 0 To UBound(a)
For j = 2 To Len(a(x))
T = UCase(Mid(a(x), j))
If Asc(T) > 64 And Asc(T) < 123 Then
If Cells(i, 2) = "" Then
Cells(i, 2) = Replace(a(x), T, " " & T)
Else
Cells(i, 2) = Cells(i, 2) & Chr(10) & Replace(a(x), T, " " & T)
End If
End If
Next
Next
Next
End Sub作者: 准提部林 時間: 2022-9-3 10:48