EXCEL根据某一单元格的值，自动复制插入行。求详细VBA代码，谢谢

Question

例子是：下图片号1-25，需要显示为共25行，第一行片号1，第二行片号2.......，最后结果是第二张图的样子。

Answer 1

1、添加内件名称数据辅助列，输入以下公式，然后向下填充公式

=LEN(N2)-LEN(SUBSTITUTE(N2,",",""))+1

2、添加行数对应辅助列，输入以下公式，然后向下填充公式

=SUM(Q$2:Q2)-Q2

3、输入以下公式，然后向右向下填充公式

=IF(ROW(A1)-1<SUM($Q:$Q),LOOKUP(ROW(A1)-1,$R$2:$R$4,B$2:B$4),"")

生成对应内件名称个数的行数内容。

 

详见附图同表举例

Answer 2

以下代码测试通过，如果使用中出现问题，请拷屏：

Option Explicit
Sub ygb()
    Dim i, j, arr1, arr2, n, m, st As Worksheet
    Set st = ActiveSheet '对当前工作表进行处理，你可以修改为处理其他表
    For i = st.UsedRange.Rows.Count To 2 Step -1 '从最后一行倒着处理回来
        arr1 = st.Cells(i, 1).Resize(1, 8) 'A-H列含有需要复制的内容
        arr2 = Split(arr1(1, 5), "-") '对E列拆分
        If UBound(arr2) > 0 Then '含有-，则插入
            n = Val(arr2(0))
            m = Val(arr2(1))
            For j = n To m
                If j <> n Then st.Rows(i).Insert
                arr1(1, 5) = j
                st.Cells(i, 1).Resize(1, 8) = arr1
            Next j
        End If
    Next i
    MsgBox "ok"
End Sub

追问

大神，你给的代码，可以成功执行。太感谢！！！！下面这种情况的，片号数值是间断的，代码该如何写：

追答

增加功能后的代码（支持100,200,210-220,300-301,400,405-450这样的复杂格式）：

 Option Explicit

Sub ygb()
    Dim i, j, k, arr1, arr2, s, n, m, st As Worksheet
    Set st = ActiveSheet '对当前工作表进行处理，你可以修改为处理其他表
    For i = st.UsedRange.Rows.Count To 2 Step -1 '从最后一行倒着处理回来
        k = i
        arr1 = st.Cells(i, 1).Resize(1, 8) 'A-H列含有需要复制的内容
        For Each s In Split(arr1(1, 5), ",")  '对E列拆分
            arr2 = Split(s, "-")
            n = Val(arr2(0))
            If UBound(arr2) > 0 Then m = Val(arr2(1)) Else m = n
            For j = n To m
                If k <> i Then st.Rows(i).Insert
                arr1(1, 5) = j
                st.Cells(i, 1).Resize(1, 8) = arr1
                k = k + 1
            Next j
        Next s
    Next i
    MsgBox "ok"
End Sub

Answer 3

Sub cs()
Dim b(1 To 9999, 1 To 8)
a = ActiveSheet.Range("A1").CurrentRegion.Resize(, 8)
For i = 1 To UBound(a)
    s = Split(a(i, 5), "-")
    For j = s(0) To s(UBound(s))
        p = p + 1
        For k = 1 To 8
            b(p, k) = a(i, k)
        Next
        b(p, 5) = j
    Next
Next
If Sheets.Count < 2 Then Sheets.Add
Sheets(2).Range("A2").Resize(p, 8) = b
Sheets(2).Activate
End Sub

Answer 4

Sub 填充()
Dim x%, y%
x = Range("f2") + 1
Rows("2:" & x).Select
Selection.FillDown
For y = 2 To x
Cells(y, 5) = y - 1
Next
End Sub