Public Sub mySub()
Dim shS As Worksheet: Set shS = ActiveSheet '源数据表，当前活动表
Dim rS&: rS = 1 '源数据表，从这行开始读取数据
Dim rC&: rC = 300 '每次读取的行数
Dim rNew$: rNew = 1 '新建表内，数据粘贴到这行
Dim rZ&: rZ = shS.UsedRange.Row + shS.UsedRange.Rows.Count - 1
Dim shNew As Worksheet, nm$, n%, r&
r = rS
Do While r
n = n + 1
Set shNew = Worksheets.Add(after:=Sheets(Worksheets.Count))
nm = ＂表 ＂ & rC & ＂_＂ & n
Call ShNm(shNew, nm)
shS.Rows(r).Resize(rC).Copy shNew.Rows(rNew)
r = rC * n + rS
Loop
MsgBox ＂ok＂
End Sub
Public Sub ShNm(sh As Worksheet, nm As Variant)
On Error Resume Next
100:
sh.Name = nm
If Err.Number 0 Then
Err.Clear
nm = Application.InputBox( _
＂《 ＂ & nm & ＂ 》已经存在！＂ & Chr(10) & Chr(10) & ＂请输入新表名：＂， _
＂请输入新表名＂， nm & ＂_new＂, _
Type:=2)
If nm = False Then MsgBox ＂输入不正确，退出程序！＂： End
GoTo 100
End If
End Sub
Sub Macro6()
'
' Macro6 Macro
'
'
Selection.TextToColumns Destination:=Range(＂A1＂), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=＂*＂, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns(＂A:A＂).Select
Selection.Replace What:=＂PL＂, Replacement:=＂＂, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns(＂C:D＂).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(＂C1＂).Select
ActiveCell.FormulaR1C1 = ＂=MIN(RC[-2],)＂
Range(＂C1＂).Select
ActiveCell.FormulaR1C1 = ＂=MIN(RC[-2],RC[-1])＂
Range(＂D1＂).Select
ActiveCell.FormulaR1C1 = ＂=MAX(RC[-3],RC[-2])＂
Range(＂C1:D1＂).Select
Selection.AutoFill Destination:=Range(＂C1:D1000＂)
Range(＂C:D＂).Select
Columns(＂A:B＂).Select
Range(＂B1＂).Activate
Columns(＂C:D＂).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns(＂A:B＂).Select
Range(＂B1＂).Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns(＂A:B＂).Select
Selection.Replace What:=＂0＂, Replacement:=＂＂, LookAt:=xlWhole, _
_
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
注意：使用时先选中A列再运行宏，被分裂列必须在A列哦，而且BC两列是空的，不然会覆盖掉（呵呵时间短，做的不是特别智能）而且行数不超过1000行。呵呵不然会有点慢所以范围就定了1000行。你也是搞钢结构的？哈偶也是哦
Option Explicit
Sub test()
Dim rng As Range
Dim arr As Variant
Dim k As Integer
For Each rng In Selection
rng.Value = Replace(rng.Value, ＂:＂, ＂/＂)
arr = Split(rng.Value, ＂/＂)
k = UBound(arr) + 1
rng.Resize(1, k) = arr
Erase arr
Next rng
End Sub关于怎么粘贴代码我估计你会，就不啰嗦了，按下图运行我给你写的代码就可以了：
step-1
step-2
step-3
step-4
点击【开发工具】-【Visual Basic】或者Alt+F11的快捷键进入VBE编辑界面。
选择插入一个新的模块
粘贴下列代码在模块中：
Sub CFGZB()
Dim myRange As Variant
Dim myArray
Dim titleRange As Range
Dim title As String
Dim columnNum As Integer
myRange = Application.InputBox(prompt：=＂请选择标题行：＂， Type:=8)
myArray = WorksheetFunction.Transpose(myRange)
Set titleRange = Application.InputBox(prompt：=＂请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”＂， Type:=8)
title = titleRange.Value
以上是将一个Excel表格分割成每个sheet包含300行的宏的详细内容。更多信息请关注PHP中文网其他相关文章！
