根据单元里姓名多少拆分行

titi012

参与一下...

1. Sub tt()
   
2. 
   
3. Dim Arr, Srr, Nrr(), Mrr(), x&, y&, N&
   
4. Arr = Sheet1.Range("a1").CurrentRegion
   
5. ReDim Mrr(1 To UBound(Arr) * 9)
   
6. ReDim Nrr(1 To UBound(Arr) * 9)
   
7. 
   
8. For x = 3 To UBound(Arr)
   
9.     If Arr(x, 6) = "" Then
   
10.         N = N + 1
    
11.         Mrr(N) = ""
    
12.         Nrr(N) = x
    
13.     Else
    
14.         Srr = Split(Arr(x, 6), "、")
    
15.         For y = 0 To UBound(Srr)
    
16.             N = N + 1
    
17.             Mrr(N) = Srr(y)
    
18.             Nrr(N) = x
    
19.         Next y
    
20.     End If
    
21. Next x
    
22. 
    
23. ReDim Brr(1 To N, 1 To UBound(Arr, 2))
    
24. For x = 1 To N
    
25.     For y = 1 To UBound(Arr, 2)
    
26.         Brr(x, y) = Arr(Nrr(x), y)
    
27.     Next y
    
28.     Brr(x, 6) = Mrr(x)
    
29. Next x
    
30. 
    
31. Sheet2.Range("A3").Resize(N, UBound(Arr, 2)) = Brr
    
32. 
    
33. End Sub

复制代码

lyfegf

cyq4896

参与一下..

章州

Sub 拆分数据()
    Dim arr, brr, crr, k&, m&, j&, x&
    arr = Sheet1.Range("a1").CurrentRegion
    With Sheet2
    For m = 3 To UBound(arr)
        brr = Split(arr(m, 6), "、")
        If UBound(brr) > 0 Then
            For x = 0 To UBound(brr)
            k = k + 1
        For j = 1 To 5
            .Cells(k + 2, j) = arr(m, j)
            .Cells(k + 2, j + 6) = arr(m, j + 6)
        Next
            .Cells(k + 2, j) = brr(x)
            .Cells(k + 2, j + 6) = arr(m, j + 6)
            .Cells(k + 2, j + 7) = arr(m, j + 7)
        Next
        Else
            k = k + 1
        For j = 1 To 5
            .Cells(k + 2, j) = arr(m, j)
            .Cells(k + 2, j + 6) = arr(m, j + 6)
        Next
            .Cells(k + 2, j) = arr(m, j)
            .Cells(k + 2, j + 6) = arr(m, j + 6)
            .Cells(k + 2, j + 7) = arr(m, j + 7)
        End If
    Next
    End With
End Sub
我凑凑热闹，我发现你们写的都很简单啊，我再看一下你们的逻辑

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2023.12.17
   
2.     Dim arr, brr
   
3.     With Sheets("表1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .Range("a1:m" & r)
   
6.     End With
   
7.     ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
8.     On Error Resume Next
   
9.     For i = 3 To UBound(arr)
   
10.         If arr(i, 6) = Empty Then
    
11.             m = m + 1
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 brr(m, j) = arr(i, j)
    
14.             Next
    
15.         Else
    
16.             b = Split(arr(i, 6), "、")
    
17.             For x = 0 To UBound(b)
    
18.                 m = m + 1
    
19.                 For j = 1 To UBound(arr, 2)
    
20.                     brr(m, j) = arr(i, j)
    
21.                 Next
    
22.                 brr(m, 6) = b(x)
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     With Sheets("表2")
    
27.         .UsedRange.Offset(2).ClearContents
    
28.         .[a3].Resize(m, UBound(arr, 2)) = brr
    
29.     End With
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

ykcbf1100

参与一下，附件供参考。。。