将一个多工作表的工作簿拆分成多个工作溥

可口可乐101

excel海 发表于 2020-3-6 17:27
写个简单的吧

这么好的代码我不会使用

感谢老师，你花费了不少时间。我再学习一下。

可口可乐101

这是提示

1055751654

Sub 学习学习()
Dim sh As Worksheet
Dim wb As Workbook
For Each sh In Worksheets
    If sh.Visible = True Then
    sh.Copy
Set wb = ActiveWorkbook
    wb.SaveAs ThisWorkbook.Path & "\" & sh.Name & ".xlsx"
    wb.Close
End If
Next
End Sub

可口可乐101

1055751654 发表于 2020-3-6 19:40
Sub 学习学习()
Dim sh As Worksheet
Dim wb As Workbook

感谢老师相助

excel海

可口可乐101 发表于 2020-3-6 18:39
这是提示

""里的斜杠又没了,自己加上吧

excel海

可口可乐101 发表于 2020-3-6 18:39
这是提示

Private Sub Test()
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Dim mypath, fname, wbk As Workbook
    mypath = ThisWorkbook.Path & "\*.xls"
    fname = Dir(mypath)
    Do
        If fname <> ThisWorkbook.Name Then
           Set wbk = Workbooks.Open(ThisWorkbook.Path & "\" & fname)
            wbk.Sheets(1).Cells.Copy
            With ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                .Paste
                .Name = Left(fname, Len(fname) - 4)
            End With
            wbk.Close False
        End If
         fname = Dir()
    Loop While fname <> ""
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
End Sub