Tạo file mới với các sheet của một file

[salam]

Chúc các thành viên GPE một ngày vui vẻ.
Em có một file có rất nhiều sheet khoảng 30 sheet. Nay em muốn tạo thành 30 file, mỗi file là một sheet của file gốc (giống như ta dùng copy or move to new book) nhưng thao tác hơi lâu. Các bác có cách nào nhanh hơn chỉ bảo cho em với. (Bằng cách nào cũng được).
Cảm ơn các bác.

 

[whitemouse]

bạn có thể sử dụng vlookup để dò tìm giá trị trên từng sheet của file gốc or sử dụng đường link để link đến sheet cần tìm của file gốc.

 

[boong]

Em không biết làm nhưng em nghĩ mấy đường link này chắc có thể giúp được anh đó: http://www.giaiphapexcel.com/forum/forumdisplay.php?f=79 http://www.giaiphapexcel.com/forum/showthread.php?t=38 http://www.giaiphapexcel.com/forum/showthread.php?t=35

 

[Mr Okebab]

Chúc các thành viên GPE một ngày vui vẻ.
Em có một file có rất nhiều sheet khoảng 30 sheet. Nay em muốn tạo thành 30 file, mỗi file là một sheet của file gốc (giống như ta dùng copy or move to new book) nhưng thao tác hơi lâu. Các bác có cách nào nhanh hơn chỉ bảo cho em với. (Bằng cách nào cũng được).
Cảm ơn các bác.

Bạn thử nhé :

Sub TrichXuat()
    Application.ScreenUpdating = False
    On Error GoTo thoat
    Dim MyPath As String, TenFile As String, FullPath As String
    Dim i As Integer
    MyPath = ActiveWorkbook.Path
    For i = 1 To 30
        TenFile = ActiveWorkbook.Name
        TenFile = Left(TenFile, Len(TenFile) - 4) & "_" & Format(i, "00") & ".xls"
        FullPath = MyPath & "\" & TenFile
        
        Sheets(Array(ActiveSheet.Name)).Copy
        ActiveWorkbook.SaveAs Filename:=FullPath, FileFormat:= _
                              xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                            , CreateBackup:=False
        Windows(TenFile).Activate
        With Workbooks(TenFile)
            .Close (True)
        End With
    Next
thoat:
    Application.ScreenUpdating = True
End Sub

Bạn có thể thay đổi ActiveWorkbook thành ThisWorkbook

Thân!

 

[salam]

Bác Bắb ơi em chạy code của Bác nó ra 30 file nhưng nó chỉ là một sheet (activesheet) thôi. Bác xem lại giúp em với. Nếu lấy được tên sheet làm tên file thì tốt quá.
Em cám ơn.

 

[Mr Okebab]

Bác Bắb ơi em chạy code của Bác nó ra 30 file nhưng nó chỉ là một sheet (activesheet) thôi. Bác xem lại giúp em với. Nếu lấy được tên sheet làm tên file thì tốt quá.
Em cám ơn.

Do chưa đọc kỹ đề bài : Mỗi sheet sẽ được copy thành 1 File riêng biệt với tên File đó chính là tên của Sheet được copy:

Sub TrichXuat()
    Application.ScreenUpdating = False
    On Error GoTo thoat
    Dim MyPath As String, TenFile As String, FullPath As String
    Dim i As Integer
    Dim Sh As Worksheet
    MyPath = ActiveWorkbook.Path
    For Each Sh In ActiveWorkbook.Worksheets
        TenFile = Sh.Name & ".xls"
        FullPath = MyPath & "\" & TenFile
        Sheets(Array(ActiveSheet.Name)).Copy
        ActiveWorkbook.SaveAs Filename:=FullPath
        Windows(TenFile).Close (True)
    Next
thoat:
    Application.ScreenUpdating = True
End Sub

Thân!

 

[minhlev]

Tôi có đoạn code củ chuối này (chạy trong Office2003), bác xem được không nhé.

Sub Trich_xuat()
On Error Resume Next
Application.ScreenUpdating = False
Dim FileGoc As Workbook, FullPath As String, TenFile As String
Set FileGoc = ActiveWorkbook
FullPath = FileGoc.Path
TenFile = Left(FileGoc.Name, Len(FileGoc.Name) - 4)
For i = 1 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FullPath & "\" & TenFile & i & ".xls"
    FileGoc.Activate
Next
Application.ScreenUpdating = True
End Sub

 

[Mr Okebab]

Tôi có đoạn code củ chuối này (chạy trong Office2003), bác xem được không nhé.

Sub Trich_xuat()
On Error Resume Next
Application.ScreenUpdating = False
Dim FileGoc As Workbook, FullPath As String, TenFile As String
Set FileGoc = ActiveWorkbook
FullPath = FileGoc.Path
TenFile = Left(FileGoc.Name, Len(FileGoc.Name) - 4)
For i = 1 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FullPath & "\" & TenFile & i & ".xls"
    FileGoc.Activate
Next
Application.ScreenUpdating = True
End Sub

Cách của bạn cũng tốt đấy. Tuy nhiên lại chưa làm được : Tên File mới được tạo ra trùng với tên Sheet được copy.

Thân!

 

[minhlev]

Cách của bạn cũng tốt đấy. Tuy nhiên lại chưa làm được : Tên File mới được tạo ra trùng với tên Sheet được copy.

Thân!

Nếu vậy thì sửa đoạn code này

ActiveWorkbook.SaveAs Filename:=FullPath & "\" & TenFile & i & ".xls"

Thành đoạn code này

ActiveWorkbook.SaveAs Filename:=FullPath & "\" & ActiveSheet.Name & ".xls"

 

[salam]

Bác Bắp ơi tên thì OK nhưng nó chỉ cóp activesheet thôi Bác à. 30 file tên thì đúng nhưng bên trong chỉ là một sheet. VD: em đang ở Sheet3 chạy code thì nó cóp 30 file là sheet3.
Của Bác Minhlev thì cóp được ra 30 file của từng sheet rất Ok. Tên file thì vẫn chưa đặt theo tên sheet và chưa close file khi tạo file.
Các bác giúp em với.
Vì tên sheet của em em đặt theo tên phòng để gửi cho các phòng, mỗi phòng một file.
Cám ơn các Bác đã nhiệt tình giúp đỡ em.

 

[minhlev]

Bác xem đoạn code sau đã đáp ững được yêu cầu chưa nhé.

Sub Macro1()
On Error Resume Next
Application.ScreenUpdating = False
Dim FileGoc As Workbook, FullPath As String, TenFile As String
Set FileGoc = ActiveWorkbook
FullPath = FileGoc.Path
TenFile = Left(FileGoc.Name, Len(FileGoc.Name) - 4)
For i = 1 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FullPath & "\" & ActiveSheet.Name & ".xls"
    ActiveWorkbook.Close
    FileGoc.Activate
Next
Application.ScreenUpdating = True
End Sub

 

[Mr Okebab]

Bác Bắp ơi tên thì OK nhưng nó chỉ cóp activesheet thôi Bác à. 30 file tên thì đúng nhưng bên trong chỉ là một sheet. VD: em đang ở Sheet3 chạy code thì nó cóp 30 file là sheet3.
Của Bác Minhlev thì cóp được ra 30 file của từng sheet rất Ok. Tên file thì vẫn chưa đặt theo tên sheet và chưa close file khi tạo file.
Các bác giúp em với.
Vì tên sheet của em em đặt theo tên phòng để gửi cho các phòng, mỗi phòng một file.
Cám ơn các Bác đã nhiệt tình giúp đỡ em.

Xin lỗi, làm chưa kịp test. Sửa lại xong thì minhlev đã làm xong rồi, tiếc công nên cứ post lên.

Sub TrichXuat()
    Application.ScreenUpdating = False
    On Error Resume Next
    Dim MyPath As String, TenFile As String, FullPath As String
    Dim Sh As Worksheet
    MyPath = ActiveWorkbook.Path
    For Each Sh In ActiveWorkbook.Worksheets
        TenFile = Sh.Name & ".xls"
        FullPath = MyPath & "\" & TenFile
        Sh.Copy
        ActiveWorkbook.SaveAs Filename:=FullPath
        Windows(TenFile).Close (True)
    Next
    Application.ScreenUpdating = True
End Sub

Thân!

 

[ngvanho]

TÔI SỬA ĐOẠN CODE CỦA BẠN NHƯ SAU

Sub Trich_xuat()
On Error Resume Next
Application.ScreenUpdating = False
Dim FileGoc As Workbook, FullPath As String, TenFile As String
Set FileGoc = ActiveWorkbook
FullPath = FileGoc.Path
For i = 1 To Sheets.Count
Sheets(i).Copy
TenFile = ActiveCell.Worksheet.Name
ActiveWorkbook.SaveAs Filename:=FullPath & "\" & TenFile & ".xls"
ActiveWorkbook.Save
ActiveWorkbook.Close
FileGoc.Activate
Next
Application.ScreenUpdating = True
End Sub

 

[salam]

Cám ơn mọi người đã giúp đỡ. với các phương pháp của các Bác đưa ra em đã áp dụng rất thành công cho công việc của em, rất nhanh và chính xác. Khi chưa có giải pháp em cứ phải làm thủ công rất mất thời gian. Một lần nữa cám ơn các Bác, cám ơn GPE.