大神们，帮忙写一个拆分程序呗，或者帮我修改下程序，谢谢

huangkepan

大神们，帮忙写一个拆分程序呗，或者帮我修改下程序，谢谢                               
我自己现有程序实现不了；
Sub splitting()
startRow = 2
endrow = ActiveSheet.Range("A65535").End(xlUp).Row
i = startRow

rowx = 1
Do While i <= endrow
      nameQty = UBound(Split(Cells(i, 2), "、", , vbTextCompare)) + 1
      For j = 1 To nameQty
      Cells(rowx + 1, 4).Value = Split(Cells(i, 2), "、", , vbTextCompare)(j - 1)
      Cells(rowx + 1, 3).Value = Cells(i, 1).Value
      rowx = rowx + 1
      Next
      rowx = rowx - 1


i = i + 1

Loop
End Sub

mytto88

Sub tt()
    Dim arr(), last_row As Long, brr()
    Application.DisplayAlerts = False
    irow = 3
    With Sheet1
        last_row = .Cells(Rows.Count, 2).End(3).Row
        arr = .Range("a3:b" & last_row).Value
        ReDim brr(1 To UBound(arr) * 100, 1 To 2)
    End With
    For i = 1 To UBound(arr)
        arrtemp = Split(arr(i, 2), "、")
        For j = 0 To UBound(arrtemp)
            If arrtemp(j) <> "" Then
                n = n + 1
                brr(n, 1) = arr(i, 1)
                brr(n, 2) = arrtemp(j)
            End If
        Next j
    Next i
   
    With Sheet2
        .Range("d3").CurrentRegion.Clear
        .Range("d3").Resize(n, 2) = brr
        setFormat .Range("d3").Resize(n, 2)
        For i = 3 To n + 3
            
            If .Range("d" & i) <> .Range("d" & i + 1) Then
                irow2 = i
                .Range("d" & irow & ":d" & irow2).Merge
                irow = i + 1
            End If
        Next
    End With
    Application.DisplayAlerts = True
End Sub


Sub setFormat(rng As Range)
    rng.Borders.LineStyle = 1
    rng.HorizontalAlignment = xlCenter
End Sub

huangkepan

各位大侠大神大仙，帮下忙呗

huangkepan

mytto88 发表于 2019-7-3 14:12
Sub tt()
    Dim arr(), last_row As Long, brr()
    Application.DisplayAlerts = False

大侠，程序很强大，今天您的答案才显示出来，能不能帮我修改一下，我测试过了很好，只是加了Range("d3").CurrentRegion.Clear这段程序之后，第二行和F列如果要填字符的话，F\G\H\E后面如果有字符的话就会清空，能不能帮我稍微修改一下，使的清空范围控制在没有字符的行，谢谢

mytto88

huangkepan 发表于 2019-7-7 22:39
大侠，程序很强大，今天您的答案才显示出来，能不能帮我修改一下，我测试过了很好，只是加了Range("d3"). ...

range("d3:e10000").clear

huangkepan

mytto88 发表于 2019-7-8 19:19
range("d3:e10000").clear

厉害了，我的神啊