如何用VBA实现智能分列呢？

huys

现在高版本的电子表格都有智能分列功能，如下表：
分列前：

分列后：



请问各位大哥大姐小弟小妹，如果用VBA处理，如何实现上面的智能分列功能呢？

工作簿1.rar (8.47 KB, 下载次数: 8)

2024-4-1 20:56 上传

点击文件名下载附件

ykcbf1100

用正则拆分

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.1
   
2.     r = Cells(Rows.Count, "a").End(xlUp).Row
   
3.     Columns("G:H") = ""
   
4.     arr = [a1].Resize(r, 8)
   
5.     Set reg = CreateObject("VBScript.Regexp")
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 1)
   
8.         With reg
   
9.             .Pattern = "\D+"
   
10.             arr(i, 7) = .Replace(s, "")
    
11.             arr(i, 8) = Replace(s, arr(i, 7), "")
    
12.         End With
    
13.     Next
    
14.     [a1].Resize(r, 8) = arr
    
15.     MsgBox "OK！"
    
16. End Sub
    

复制代码

limonet

关键字：￥￥￥￥

limonet

Sub limonet()
    Dim i%
    With CreateObject("vbscript.regexp")
        .Pattern = "(\d+)(.*)"
        For i = 2 To 5
            Cells(i, "C").Resize(1, 2) = Split(.Replace(Cells(i, "A"), "$1￥$2"), "￥")
        Next i
    End With
End Sub

liulang0808

Sub test()
    r = Cells(Rows.Count, "a").End(xlUp).Row
    arr = [a1].Resize(r, 2)
    With CreateObject("VBScript.Regexp")
        .Pattern = "\d+"
        For i = 2 To UBound(arr)
            str1 = arr(i, 1)
            If .test(str1) Then
                arr(i, 1) = .Execute(str1)(0)
                arr(i, 2) = .Replace(str1, "")
            End If
        Next
    End With
    [d1].Resize(r, 2) = arr
End Sub

明天会更好zj

如果数据规范，这个很简单的

limonet

很有规律用ctrl+E
或公式：=MAX(IFERROR(--LEFT(A2,ROW(INDIRECT("1:"&LEN(A2)))),0))
=SUBSTITUTE(A2,MAX(IFERROR(--LEFT(A2,ROW(INDIRECT("1:"&LEN(A2)))),0)),"")

huys

多谢各位！

swl4561255

1. Sub test()
   
2. ar = [A1].End(4).Row
   
3. arr = Range("A2:A" & ar)
   
4. Dim brr(1 To 100, 0 To 1)
   
5. For i = 1 To ar - 1
   
6. Set reg = CreateObject("vbscript.regexp")
   
7.    With reg
   
8.       .Global = False
   
9.       .Pattern = "(\d+)([\u4E00-\u9FA5]+)"
   
10.       Set ma = .Execute(arr(i, 1))
    
11.         For j = 0 To 1
    
12.           brr(i, j) = ma(0).submatches(j)
    
13.         Next
    
14.    End With
    
15. Set reg = Nothing
    
16. Next
    
17. [G2].Resize(ar - 1, 2) = brr
    
18. End Sub

复制代码