求助：识别第2行斜杠分列？

czr0373

这个斜杠分列看似简单，并不好弄
甭管第2行上下是什么数据，就在第2行数据斜杠"/"左边分列
而且，斜杠在第2行的位置和个数都不固定。

hefuqing

你要结果是什么

czr0373

hefuqing 发表于 2018-8-29 19:23
你要结果是什么

图示为结果，红竖线去掉为源数据

ggmmlol

按固定列宽分列，并同时录制宏代码：

1. Sub Macro1()
   
2.     Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
   
3.         FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(27, 1), Array(33, 1), Array(42, 1), _
   
4.         Array(51, 1)), TrailingMinusNumbers:=True
   
5. End Sub

复制代码

hefuqing

1. Sub ddd()
   
2. Dim brr(), crr()
   
3. r = Sheets("源").Cells(Sheets("源").Rows.Count, 1).End(xlUp).Row
   
4. arr = Sheets("源").Range("a1:a" & r)
   
5. ReDim brr(1 To r)
   
6. For i = 1 To UBound(arr)
   
7. n = n + 1
   
8. brr(n) = Split(arr(i, 1), " ")
   
9. Next
   
10. 
    
11. ReDim crr(1 To UBound(brr), 1 To 6)
    
12. crr(1, 1) = brr(1)(0)
    
13. crr(1, 2) = brr(1)(4)
    
14. crr(1, 3) = brr(1)(20)
    
15. crr(1, 4) = brr(1)(21)
    
16. crr(1, 5) = brr(1)(24)
    
17. crr(1, 6) = brr(1)(30)
    
18. m = 1
    
19. For i = 2 To UBound(brr)
    
20. m = m + 1
    
21. If brr(i)(0) = "/" Then
    
22. crr(m, 1) = brr(i)(0)
    
23. crr(m, 2) = brr(i)(5)
    
24. crr(m, 3) = brr(i)(25)
    
25. crr(m, 4) = brr(i)(30)
    
26. crr(m, 5) = brr(i)(38)
    
27. crr(m, 6) = brr(i)(46)
    
28. 
    
29. ElseIf brr(i)(0) = "" Then
    
30. crr(m, 1) = ""
    
31. crr(m, 2) = ""
    
32. crr(m, 3) = ""
    
33. crr(m, 4) = brr(i)(33)
    
34. crr(m, 5) = brr(i)(36)
    
35. crr(m, 6) = brr(i)(41)
    
36. Else
    
37. crr(m, 1) = brr(i)(0)
    
38. crr(m, 2) = brr(i)(4) & brr(i)(5) & brr(i)(6) & brr(i)(7) & brr(i)(8)
    
39. crr(m, 3) = brr(i)(10)
    
40. crr(m, 4) = brr(i)(12)
    
41. crr(m, 5) = brr(i)(15)
    
42. crr(m, 6) = brr(i)(20)
    
43. End If
    
44. Next
    
45.   Sheets("果").[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
    
46. End Sub

复制代码

kankan1030

选中A列，数据——分列（固定宽度），按提示操作。简单问题复杂化！

hefuqing

czr0373 发表于 2018-8-29 19:41
图示为结果，红竖线去掉为源数据

写的这么好才1分啊

czr0373

hefuqing 发表于 2018-8-29 20:25
写的这么好才1分啊

数据长度增长，
行数增多，结果并不理想
但还是非常感谢，

一把小刀闯天下

'如果分割结果不满意先设置一下字体及字号，然后再设置分隔符位置，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, p, t, pos(), n
  On Error GoTo errmsg
  arr = Sheets("源").[a1].CurrentRegion
  For i = 1 To Len(arr(2, 1))
    t = InStr(p + 1, arr(2, 1), "/")
    If t > 0 Then
      p = t: n = n + 1
      ReDim Preserve pos(1 To n): pos(n) = t
    Else
      Exit For
    End If
  Next
  ReDim brr(1 To UBound(arr, 1), 1 To UBound(pos))
  For i = 1 To UBound(arr, 1)
    p = pos
    For j = 2 To UBound(p)
      t = Trim(Mid(arr(i, 1), p(j - 1), p(j) - p(j - 1)))
      n = 0
      For k = 1 To Len(t)
        If Asc(Mid(t, k, 1)) < 0 Then n = n + 1
      Next
      If n > 0 Then
        For k = j To UBound(p): p(k) = p(k) - n: Next
        t = Trim(Mid(arr(i, 1), p(j - 1), p(j) - p(j - 1)))
      End If
      brr(i, j - 1) = t
    Next
    brr(i, j - 1) = Trim(Right(arr(i, 1), Len(arr(i, 1)) - p(UBound(p)) + 1))
  Next
  With Sheets("果").[a1]
    .CurrentRegion.ClearContents
    .Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  End With
  Exit Sub
errmsg:
  Debug.Print Err.Number
  MsgBox "确认行长度：" & i & vbNewLine & "或第2行分割符号有问题"
End Sub