如何把单元格中用“/"串连的制程独立出来另作一行

小白兔3399

大家好：

系统导出来的报表有一个单元格是用”/"把不同的生产制程串连在一起的，请问有没有什么办法，能够按“/"为条件，把不同制程提取出来另作一行呀，感谢 测试表.zip (11.02 KB, 下载次数: 7)

2023-4-18 20:46 上传

点击文件名下载附件

liulang0808

Private Sub CommandButton1_Click()
    arr = Sheets(1).[a1].CurrentRegion
    brr = Sheets(1).[a1].Resize(UBound(arr) * 10, UBound(arr, 2))
    r = 1
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then
            If Len(arr(j, 4)) = 0 Then
                r = r + 1
                For k = 1 To UBound(arr, 2)
                    brr(r, k) = arr(j, k)
                Next k
            Else
                crr = Split("/" & arr(j, 4), "/")
                For i = 1 To UBound(crr)
                    If Len(crr(i)) > 0 Then
                        r = r + 1
                        For k = 1 To UBound(arr, 2)
                            brr(r, k) = arr(j, k)
                        Next k
                    End If
                Next i
            End If
        End If
    Next j
    Sheets(2).[i1].Resize(r, UBound(arr, 2)) = brr
End Sub

liulang0808

附件内容供参考。。。。。。。

杨建营

请楼主参考。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("表1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a3:d" & r)
   
7.     End With
   
8.     ReDim brr(1 To UBound(arr) * 10, 1 To UBound(arr, 2))
   
9.     m = 0
   
10.     For i = 1 To UBound(arr)
    
11.         If InStr(arr(i, 4), "/") = 0 Then
    
12.             m = m + 1
    
13.             For j = 1 To UBound(arr, 2)
    
14.                 brr(m, j) = arr(i, j)
    
15.             Next
    
16.         Else
    
17.             xm = Split(arr(i, 4), "/")
    
18.             For k = 0 To UBound(xm)
    
19.                 m = m + 1
    
20.                 brr(m, 1) = arr(i, 1)
    
21.                 brr(m, 2) = arr(i, 2)
    
22.                 brr(m, 3) = xm(k)
    
23.                 brr(m, 4) = arr(i, 4)
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     With Worksheets("表2")
    
28.         .Range("a3:d" & .Rows.Count).Clear
    
29.         With .Range("a3").Resize(m, UBound(brr, 2))
    
30.             .Value = brr
    
31.             .Borders.LineStyle = xlContinuous
    
32.         End With
    
33.     End With
    
34. End Sub
    

复制代码

chxw68

写个简单的。

小白兔3399

liulang0808 发表于 2023-4-19 08:03
Private Sub CommandButton1_Click()
    arr = Sheets(1).[a1].CurrentRegion
    brr = Sheets(1).[a1] ...

小白兔3399

杨建营 发表于 2023-4-19 08:40
请楼主参考。

是我要的效果，非常感谢帮忙！

小白兔3399

chxw68 发表于 2023-4-19 09:05

小白兔3399

chxw68 发表于 2023-4-19 09:05

我试着微调了一下判断条件，果然是我要的效果，太强大了，非常感谢帮忙