Tách nhiều Sheet trong 1 file thành các file riêng

[luckyluke_2828]

Các bác cho mình hỏi,
Hiện tại mình đang có 1 file với các Sheet tên 0, 1, 2, 3, 4, 5
Mình muốn tách thành 4 file riêng lẻ với lần lượt mỗi file có một sheet từ Sheet1 đến Sheet4. Và file nào cũng có Sheet0. Tên file mới trùng với tên Sheet (mà không phải Sheet0)
Tức là File 1 gồm 2 sheet 1,0
file 2 gồm 2 sheet 2,0
....
nhờ các bạn giúp.

 

[snow25]

Các bác cho mình hỏi,
Hiện tại mình đang có 1 file với các Sheet tên 0, 1, 2, 3, 4, 5
Mình muốn tách thành 4 file riêng lẻ với lần lượt mỗi file có một sheet từ Sheet1 đến Sheet4. Và file nào cũng có Sheet0. Tên file mới trùng với tên Sheet (mà không phải Sheet0)
Tức là File 1 gồm 2 sheet 1,0
file 2 gồm 2 sheet 2,0
....
nhờ các bạn giúp.

Thử record macro ra được code sau.

    Sheets(Array("Sheet1", "Sheet2")).Select
    Sheets("Sheet2").Activate
    Sheets(Array("Sheet1", "Sheet2")).Copy

 

[Nhattanktnn]

Các bác cho mình hỏi,
Hiện tại mình đang có 1 file với các Sheet tên 0, 1, 2, 3, 4, 5
Mình muốn tách thành 4 file riêng lẻ với lần lượt mỗi file có một sheet từ Sheet1 đến Sheet4. Và file nào cũng có Sheet0. Tên file mới trùng với tên Sheet (mà không phải Sheet0)
Tức là File 1 gồm 2 sheet 1,0
file 2 gồm 2 sheet 2,0
....
nhờ các bạn giúp.

Thử code dưới:

Option Explicit

Public Sub SplitFile()
Dim mainWb As Workbook, newWb As Workbook
Dim mainWs As Worksheet, Ws As Worksheet
Dim ArrSheets(1 To 2)
Dim desPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set mainWb = ThisWorkbook
Set mainWs = mainWb.Worksheets("0")
desPath = mainWb.Path 'Chinh sua duong dan theo mong muon

ArrSheets(1) = mainWs.Name
For Each Ws In mainWb.Worksheets
    If Ws.Name <> mainWs.Name Then
        ArrSheets(2) = Ws.Name
        mainWb.Sheets(ArrSheets).Copy
        Set newWb = ActiveWorkbook
        newWb.SaveAs Filename:=desPath & "\" & Ws.Name & ".xlsx", _
                FileFormat:=xlWorkbookDefault
        newWb.Close
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub