请老师用VBA指导分拆字段，谢谢！

石来运转6888

请老师用VBA指导分拆字段，谢谢！

shiruiqiang

taller

shiruiqiang

Sub test()
Dim rng As Range
Range("k2:k1000").NumberFormat = "@"
For Each rng In Range("i3:i1000")
    If Len(rng) > 10 Then
    rng.Offset(0, 2) = Split(rng, "-")(0)
    rng.Offset(0, 4) = Split(rng, "-")(1)
    rng.Offset(0, 6) = Split(rng, "-")(2)
    End If
Next
End Sub

swl4561255

1. Sub test()
   
2. arr = Range("A1").CurrentRegion
   
3. For i = 3 To UBound(arr)
   
4.     If arr(i, 9) <> "" Then
   
5.         br = Split(arr(i, 9), "-")
   
6.         For j = 0 To 2
   
7.             arr(i, 11 + 2 * j) = br(j)
   
8.         Next
   
9.     End If
   
10. Next
    
11. [A1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
12. [A1].Resize(UBound(arr), UBound(arr, 2)).NumberFormat = "@"
    
13. End Sub

复制代码

Qs18

Sub test()
Dim rng As Range, arr, m
Dim r As Range
m = Cells(Rows.Count, "i").End(xlUp).Row
Set rng = Range("i3:i" & m)
Range("k2:k1" & m).NumberFormat = "@"
For Each r In rng
    If Len(r.Value) > 3 Then
        arr = VBA.Split(r.Value, "-")
        r.Offset(0, 2).Value = arr(0)
        r.Offset(0, 4).Value = arr(1)
        r.Offset(0, 6).Value = arr(2)
    Else
        r.Offset(0, 2).Value = ""
        r.Offset(0, 4).Value = ""
        r.Offset(0, 6).Value = ""
    End If
Next
Set rng = Nothing
End Sub  '试试

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.6
   
2.     Application.ScreenUpdating = False
   
3.     On Error Resume Next
   
4.     With Sheets("单元表")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 15)
   
7.         ReDim brr(1 To r, 1 To 5)
   
8.         For i = 3 To UBound(arr)
   
9.             m = m + 1
   
10.             If arr(i, 9) = "--" Then
    
11.                 brr(m, 1) = ""
    
12.                 brr(m, 3) = ""
    
13.                 brr(m, 5) = ""
    
14.             Else
    
15.                 st = Split(arr(i, 9), "-")
    
16.                 brr(m, 1) = st(0)
    
17.                 brr(m, 3) = st(1)
    
18.                 brr(m, 5) = st(2)
    
19.             End If
    
20.         Next
    
21.         .Columns(11).NumberFormatLocal = "@"
    
22.         .[k3].Resize(m, 5) = brr
    
23.     End With
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码

flb_2001

我想问一下，这个不用VBA也可以吧？直接用excel的分列功能：分隔符号用"-"