单行分成多行【已解决】

海缘

需要依单元格内符合“/”将单无格内容分行。
求助高人指点。
已解决：
感谢2楼、3楼、4楼、5楼、6楼、7楼的热心朋友，谢谢！

doitbest

1. Public Sub abc()
   
2. Dim ar, br(1 To 60000, 1 To 7), I, j, k, n, va, str
   
3. Dim d As Object
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheets(1).Select
   
6. ar = Range([b5], [h65536].End(3))
   
7. For I = 1 To UBound(ar)
   
8.     If InStr(ar(I, 3), "/") Then
   
9.         va = ar(I, 7) / ar(I, 4)
   
10.         str = Split(ar(I, 3), "/")
    
11.         For j = 0 To UBound(str)
    
12.             n = n + 1
    
13.             For k = 1 To 7: br(n, k) = ar(I, k): Next
    
14.             br(n, 3) = str(j)
    
15.             br(n, 4) = 1
    
16.             br(n, 7) = va
    
17.         Next
    
18.     Else
    
19.         n = n + 1
    
20.         For j = 1 To 7
    
21.         br(n, j) = ar(I, j)
    
22.         Next
    
23.     End If
    
24. Next
    
25. Worksheets.Add after:=Sheets(Sheets.Count)
    
26. [a1:g1] = Array("备案项号", "品名", "财产编号", "数量", "单位", "存放库位", "总价值")
    
27. [a2].Resize(n, UBound(br, 2)) = br
    
28. End Sub

复制代码

doitbest

请参考附件

hai167

1. Sub yy()
   
2. Dim ar, br(), cutstr As String
   
3. ar = Range("b5:h" & [d65536].End(3).Row)
   
4. ReDim br(1 To 10000, 1 To 7)
   
5. x = 1
   
6. For i = 1 To UBound(ar)
   
7.     If InStr(ar(i, 3), "/") > 1 Then
   
8.        k = Len(ar(i, 3)) - Len(Replace(ar(i, 3), "/", ""))
   
9.        For j = 1 To k + 1
   
10.            br(x, 1) = ar(i, 1)
    
11.            br(x, 2) = ar(i, 2)
    
12.            If j = 1 Then
    
13.               br(x, 3) = Left(ar(i, 3), InStr(ar(i, 3), "/") - 1)
    
14.               cutstr = br(x, 3) & "/"
    
15.            Else
    
16.               If j = k + 1 Then
    
17.                  br(x, 3) = Right(ar(i, 3), Len(ar(i, 3)) - Len(cutstr))
    
18.               Else
    
19.                  br(x, 3) = Left(Right(ar(i, 3), Len(ar(i, 3)) - Len(cutstr)), InStr(Right(ar(i, 3), Len(ar(i, 3)) - Len(cutstr)), "/") - 1)
    
20.               End If
    
21.               cutstr = cutstr & br(x, 3) & "/"
    
22.            End If
    
23.            br(x, 4) = ar(i, 4) / (k + 1)
    
24.            br(x, 5) = ar(i, 5)
    
25.            br(x, 6) = ar(i, 6)
    
26.            br(x, 7) = ar(i, 7) / (k + 1)
    
27.            x = x + 1
    
28.        Next
    
29.        cutstr = ""
    
30.     Else
    
31.        For j = 1 To 7
    
32.            br(x, j) = ar(i, j)
    
33.        Next
    
34.        x = x + 1
    
35.     End If
    
36. Next
    
37. [k5].Resize(x, 7) = br
    
38. End Sub
    

复制代码

hai167

一行自动拆成多行.rar (17.07 KB, 下载次数: 49)

2012-12-5 12:50 上传

点击文件名下载附件

hai167

doitbest代码比较简洁，学习了。

一时没想到可用split来分割字符，想到texttocolumns分列，没到split。

hai167

重新改了一下。

1. Sub tt()
   
2. Dim ar, cr, br(), cutstr As String
   
3. [k5:q65536].ClearContents
   
4. ar = Range("b5:h" & [d65536].End(3).Row)
   
5. ReDim br(1 To 10000, 1 To 7)
   
6. x = 1
   
7. For i = 1 To UBound(ar)
   
8.     If InStr(ar(i, 3), "/") > 1 Then
   
9.        cr = Split(ar(i, 3), "/")
   
10.        For j = 0 To UBound(cr)
    
11.            br(x, 1) = ar(i, 1): br(x, 2) = ar(i, 2): br(x, 3) = cr(j): br(x, 4) = ar(i, 4) / (UBound(cr) + 1)
    
12.            br(x, 5) = ar(i, 5): br(x, 6) = ar(i, 6): br(x, 7) = ar(i, 7) / (UBound(cr) + 1)
    
13.            x = x + 1
    
14.        Next
    
15.     Else
    
16.        For j = 1 To 7
    
17.            br(x, j) = ar(i, j)
    
18.        Next
    
19.        x = x + 1
    
20.     End If
    
21.     cr = ""
    
22. Next
    
23. [k5].Resize(x, 7) = br
    
24. End Sub

复制代码

海缘

hai167 发表于 2012-12-5 13:13
重新改了一下。

高手，谢谢楼上热心的朋友，谢谢！

Zamyi

1. Sub tt()
   
2. Dim a(1 To 60000, 1 To 7)
   
3. R = Range("h5", [b65536].End(3))
   
4. For i = 1 To UBound(R)
   
5.   t = Split(R(i, 3), "/")
   
6.   R(i, 4) = R(i, 4) / (UBound(t) + 1)
   
7.   For Each c In t
   
8.     n = n + 1
   
9.     For j = 1 To 2
   
10.       a(n, j) = R(i, j)
    
11.     Next
    
12.     a(n, 3) = c
    
13.     For j = 4 To 7
    
14.       a(n, j) = R(i, j)
    
15.     Next
    
16.   Next
    
17. Next
    
18. [b5].Resize(n, 7) = a
    
19. End Sub

复制代码

Zamyi

或者：

1. Sub tt()
   
2. Dim a(1 To 60000, 1 To 7)
   
3. R = Range("h5", [b65536].End(3))
   
4. For i = 1 To UBound(R)
   
5.   t = Split(R(i, 3), "/")
   
6.   R(i, 4) = R(i, 4) / (UBound(t) + 1)
   
7.   For Each c In t
   
8.     n = n + 1
   
9.     For j = 1 To 7
   
10.       If j = 3 Then a(n, j) = c Else a(n, j) = R(i, j)
    
11.     Next
    
12.   Next
    
13. Next
    
14. [b5].Resize(n, 7) = a
    
15. End Sub

复制代码