按姓名拆分成多个工作表

jacking03

乐乐2006201505 发表于 2018-1-20 21:11
Sub 表格复制()
    Dim i As Integer
    Application.ScreenUpdating = False

谢谢乐乐大侠，圆满解决了问题，又给我提供了很好的建议，大大提高了效率！！
第一种:直接拆分在原表格之后
Sub 表格复制()
    Dim i As Integer
    Application.ScreenUpdating = False
    r = Sheets(2).Cells(Rows.Count, 3).End(3).Row
    For i = 2 To r
        Sheets(19).Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Range("B3") = Sheets(2).Range("c" & i)
            .Name = .Range("B3") 'i
        End With
    Next i
    MsgBox "表格复制完毕！"
    Application.ScreenUpdating = True
End Sub
   
第二种：拆分成单独工作簿
Sub 工作表另存为单独工作簿()
    mypath = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False
    With ThisWorkbook
        For i = 20 To .Sheets.Count
            .Sheets(i).Copy
            Cells.Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            ActiveWorkbook.SaveAs Filename:=mypath & .Sheets(i).Name & ".xlsx"
            ActiveWorkbook.Close 1
        Next
    End With
    MsgBox "个人工作簿创建完毕！"
    Application.ScreenUpdating = True
End Sub

乐彩007

好东西大家分享！

jacking03

感谢EH论坛这样一个平台，供大家交流沟通分享