工作表VBA修改求助

FREEDOMH

各位大大虾：

原有一工作表在input工作表中“分类代码“ 输入8为代码执行宏自动在 output输出

前四位填写分类编号单元格，后四位填写连续号单元格。例如：12345678 分为1234，5678填写在材料表中，现在新表格中资材番号有三栏（原有2栏）需要输入10位，前两位为1组，2到5位为一组，6到10位为一组。例如：1234567890 分为12,3456,7890，新材料表在b工作表中。

本人菜鸟应如何修改以下程序呢？谢谢！

Sub Macro1()

'

' Macro1 Macro

' 儅僋儘婰榐擔 : 2001/11/14  儐乕僓乕柤 : 梟愙媄弍晹

'

    Dim psetup(30)

   

    Application.ScreenUpdating = False

   

    sheetno = Range("b1").Value

    assyno = Range("b2").Value

    assyname = Range("b3").Value

    producttype = Range("b4").Value

    productname = Range("b5").Value

    kumidai = Range("b6").Value

    drawup = Range("b7").Value

   

    Application.DisplayAlerts = False

    For Each s In Sheets

        If s.Name = "output" Then

            s.Delete

        End If

    Next

    Application.DisplayAlerts = True

   

    toprow = 10

    For i = 0 To 200

        val1 = UCase(Cells(i + toprow, 1).Value)

        If val1 = "END" Then

            Exit For

        End If

    Next i

    lineno = i

   

    page_row = 10

    Pages = (lineno - 1) \ page_row + 1

    Sheets("a").Copy after:=Sheets("input")

    ActiveSheet.Name = "output"

'    Range("W1").Value = sheetno

    Range("A30").Value = StrConv(assyno, vbWide)

    Range("E30").Value = StrConv(assyname, vbWide)

    Range("A33").Value = StrConv(producttype, vbWide)

    Range("E33").Value = productname

    Range("I30").Value = kumidai

    Range("J31").Value = drawup

    Range("W1").Value = StrConv(sheetno, vbWide) & " (1/" & Pages & ")"

    Range("A1:Z35").Copy

    For i = 1 To Pages - 1

        Cells(i * 35 + 1, 1).Select

        ActiveSheet.Paste

        Cells(i * 35 + 1, 23).Value = StrConv(sheetno, vbWide) & " (" & i + 1 & "/" & Pages & ")"

        For j = 1 To 35

            Cells(i * 35 + j, 1).RowHeight = Cells(j, 1).RowHeight

        Next j

    Next i

    For i = 0 To lineno - 1

        Page = i \ page_row

        r = (i Mod page_row) * 2 + 1

            Cells(6 + Page * 35 + r, 1) = Sheets("input").Cells(i + toprow, 1)

            Cells(6 + Page * 35 + r, 2) = StrConv(Left(Sheets("input").Cells(i + toprow, 2), 4), vbWide)

            Cells(6 + Page * 35 + r, 4) = StrConv(Mid(Sheets("input").Cells(i + toprow, 2), 5, 4), vbWide)

            Cells(6 + Page * 35 + r, 6) = StrConv(Sheets("input").Cells(i + toprow, 3), vbWide)

            Cells(6 + Page * 35 + r, 10) = StrConv(Sheets("input").Cells(i + toprow, 4), vbWide)

            Cells(6 + Page * 35 + r, 17) = Sheets("input").Cells(i + toprow, 5)

            Cells(6 + Page * 35 + r, 18) = Sheets("input").Cells(i + toprow, 6)

            Cells(6 + Page * 35 + r, 20) = Sheets("input").Cells(i + toprow, 7)

            Cells(6 + Page * 35 + r, 21) = Sheets("input").Cells(i + toprow, 8)

            Cells(6 + Page * 35 + r, 25) = Sheets("input").Cells(i + toprow, 9)

    Next i

   

'//

    Cells(1, 1).Select

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

End Sub

Sub Macro2()

'

' Macro2 Macro

' 儅僋儘婰榐擔 : 2002/2/22  儐乕僓乕柤 : 梟愙媄弍晹

'

'

    toprow = 10

    For i = 0 To 200 Step 2

        val1 = UCase(Cells(i + toprow, 1).Value)

        If val1 = "END" Then

            Exit For

        End If

        Rows(i + toprow & ":" & i + toprow).Select

        Selection.Insert Shift:=xlDown

    Next i

End Sub

Sub Macro3()

'

' Macro3 Macro

' 儅僋儘婰榐擔 : 2002/2/22  儐乕僓乕柤 : 梟愙媄弍晹

'

'

    toprow = 10

    For i = 0 To 200

        val1 = UCase(Cells(i + toprow, 1).Value)

        If val1 = "END" Then

            Exit For

        End If

        Rows(i + toprow & ":" & i + toprow).Select

        Selection.Delete Shift:=xlUp

    Next i

End Sub

grf1973

Sub 分号进B表()
Set b = Sheets("b")
  mr = [b65536].End(3).Row
  bh = Trim(Cells(mr, 2))
  left2 = Left(bh, 2)
  mid4 = Mid(bh, 3, 4)
  right4 = Right(bh, 4)
  r = 8   '根据需要自己调行数
  b.Cells(r, "B") = left2
  b.Cells(r, "D") = mid4
  b.Cells(r, "G") = right4
End Sub