làm sao để tách nhiều sheet trong một file xls thành nhiều file (1 người xem)

[diemdiem]

Em có một file xsl bao gồm nhiều sheet, bây giờ em muốn tách các sheet ra thành nhiều file, nghĩa là mỗi sheet em sẽ tách thành một file, nhưng nếu ngồi làm kiểu remo or copy thì lâu quá, có cách nào để mình thực hiện nhanh hơn không
cám ơn các bác!

 

[Quang_Hải]

Bạn xem file mẫu nghen, code được sao chép của các thầy trên diễn đàn.

 

[diemdiem]

Bạn xem file mẫu nghen, code được sao chép của các thầy trên diễn đàn.

Anh Hai ơi! Trong bài trên anh có thể hướng dẫn em cách sử dụng được không?
Em còn gà mà

 

[Quang_Hải]

Nếu bạn cần hướng dẫn thì phải có file cụ thể chứ, up file lên đi.

 

[diemdiem]

Nếu bạn cần hướng dẫn thì phải có file cụ thể chứ, up file lên đi.

Em đã gửi file vào mail cho anh rồi, anh nghiên cứu giúp em với
cám ơn anh

 

[Quang_Hải]

Đã chuyển code vào file cho bạn. Hạn chế đặt tên sheet có dấu tiếng Việt

 

[thang314]

code anh quanghai rất hay. tuy nhiên trong nhiều trường hợp người dùng có thể tách các file có nhiều sheet khác thì lại không được ổn lắm, sao anh không dùng dialog để tách cho nhiều hơn các file trong folder.

 

[Quang_Hải]

Thật thình mình chỉ mới mò mẫm VBA trong exel trong thời gian ngắn nên cũng không rành lắm, nhưng cứ gặp bài nào thì làm theo yêu cầu của bài đó thôi

 

[thanhsptk40]

Sao tách rồi nhưng công thức lại mất vậy bạn. Bạn có thể giúp mình cách tách mà công thức không mất không. Thank bạn

 

[Lequocvan]

Em áp dụng code của thầy, nhưng nay em muốn tách ra các sheet thành từng file và đổi tên file theo tên sheets(1) của workbook nguồn trước khi tách mà làm mãi không ra ah? Mong thầy chỉ giúp ah?

 

[dhn46]

Em áp dụng code của thầy, nhưng nay em muốn tách ra các sheet thành từng file và đổi tên file theo tên sheets(1) của workbook nguồn trước khi tách mà làm mãi không ra ah? Mong thầy chỉ giúp ah?

Trong thời gian chờ anh Quang Hải trả lời chính thức thì tôi tạm trả lời bạn nhé

Trong code của bạn có đoạn

[B]    .SaveAs Filename:="[COLOR=#0000cd]c:[/COLOR]\[COLOR=#ff8c00]fripcas[/COLOR]" & "\" & [COLOR=#800080]tenWs [/COLOR]& "\" & [COLOR=#ff0000].Sheets(1).Name[/COLOR], FileFormat:=xlNormal[/B]

Tức là:

- Tại ổ đĩa C
- Tại thư mục có tên fripcas
- Tại thư mục con của fripcas có tên tenWs
- Sẽ lưu file excel có tên là: .Sheets(1).Name

Vậy bạn đã đảm bảo đủ thư mục chưa?

 

[Lequocvan]

Bác nói đúng rồi, ý em là khi tách sheet HoiSo, PGDso03 ra thành từng file (lưu vào thư mục tương ứng là HoiSo, PGDso03) (thư mục này tự tạo bằng tay ah) có tên là HoiSo, PGDso03 trong 2 file đó, sheet có tên là giống với tên sheet đầu tiên trong file trước khi tách ra ấy ah.
code em vẫn để trong file ấy,

 

[dhn46]

Bác nói đúng rồi, ý em là khi tách sheet HoiSo, PGDso03 ra thành từng file (lưu vào thư mục tương ứng là HoiSo, PGDso03) (thư mục này tự tạo bằng tay ah) có tên là HoiSo, PGDso03 trong 2 file đó, sheet có tên là giống với tên sheet đầu tiên trong file trước khi tách ra ấy ah.
code em vẫn để trong file ấy,

Không hiểu câu hỏi của bạn ah.

Tôi test và thấy:

Nếu bạn làm chuẩn theo #11 thì sẽ lưu file tương ứng ra theo đúng nội dung Code.

=> Trong bài #12 bạn nói:

Đã làm các thư mục bằng tay tại ổ C (tức là chuẩn #11) thì kết quả bạn thu được là gì?

Đã tạo file như không đúng tên? Không tạo file? Lỗi Code (dòng nào)? ...

Bạn mô tả cụ thể thì mới biết được ý tưởng bạn nhé.

 

[Lequocvan]

em đã tách ra sheet HoiSo.xlsx và lưu đúng vào thư mục HoiSo. và các sheet khác tương tự. Nhưng ở đây, em muốn là tên file HoiSo.xlsx được đổi thành giống tên của Sheets đầu tiên trong "Hoi GPE ve code.xlsx" và tên sheet của trong file giống tên file luôn ah.

 

[dhn46]

em đã tách ra sheet HoiSo.xlsx và lưu đúng vào thư mục HoiSo. và các sheet khác tương tự. Nhưng ở đây, em muốn là tên file HoiSo.xlsx được đổi thành giống tên của Sheets đầu tiên trong "Hoi GPE ve code.xlsx" và tên sheet của trong file giống tên file luôn ah.

Bạn làm như sau

Khai báo thêm 1 biến nữa

    TenLuu = Sheets(1).Name

Sửa đoạn code save thành

         .SaveAs Filename:="D:" & "\" & tenWs & "\" & TenLuu, FileFormat:=xlNormal

 

[Lequocvan]

Nhờ các Thầy giúp em chỉnh sửa code này thì như thế nào ah?

Đầu xuân Bính Thân 2016, Kính chúc toàn thể GPE an khang thịnh vượng!

Kể cũng lạ, có mỗi mình em online!
Em mở lần lượt từng file xls trong từng thư mục con của c:\data (6 file, nhỏ trong 6 thư mục con: HoiSo, PGDso03, PGDso04, PGDso07, PGDs009, PGDso10). Nhưng trong phần thủ tục DoTheJob thì em lại ko biết chỉnh như thế nào để khi mở file HoiSo.xls (PGDso03.xls, PGDso04.xls, PGDso07.xls, PGDso09.xls, PGDso10.xls) ra thì:
1. Đặt tên sheet (mỗi file chỉ có 1 sheet) theo giá trị của cell G1.
=> thì nó lại cứ lấy giá trị cell G1 của cái thằng workbook em có code.
2. Save as thành file khác có tên giống tên của sheet, lưu trữ cùng chỗ, thư mục con tương ứng.
3. Đóng lại.
Em mày mò rồi mà cứ loạn cả lên. Mong các thầy giúp sức, chỉ bảo ah?

Private myN As Long
Private myFiles() As String

Sub Dat_ten_theo_Sheet()

myN = 0
SearchFiles "c:\data", "*.xls", True '<- True for search subfolder...
If myN > 0 Then
DoTheJob
Else
MsgBox "No file found"
End If​

End Sub

Private Sub DoTheJob()

Dim i As Long
For i = 1 To myN
​

With Workbooks.Open(myFiles(1, i) & "" & myFiles(2, i))
​

'.Sheets("Sheet1").Range("C12").Formula = ("Enter text here")
ActiveSheet.Name = Range("G1").Value
Dim tenWsVBA, tenWs As String
tenWsVBA = ActiveSheet.CodeName
tenWs = ActiveSheet.Name
'.SaveAs fileName:="c:\Data" & "" & tenWs & "" & .Sheets(1).Name & ".xls"
MsgBox "Hay xem lai!", vbOKOnly, "Bao loi"
.Close True​

End With​

Next​

End Sub


Private Sub SearchFiles(ByVal myDir As String, ByVal myFileName As String, _
ByVal SearchSubFolder As Boolean)

Dim fso As Object, myFile As Object, myFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.GetFolder(myDir).Files
​

If myFile.Name Like myFileName Then
myN = myN + 1
ReDim Preserve myFiles(1 To 2, 1 To myN)
myFiles(1, myN) = myDir
myFiles(2, myN) = myFile.Name
End If​

Next
If SearchSubFolder Then
​

For Each myFolder In fso.GetFolder(myDir).Subfolders
​

SearchFiles myDir & "" & myFolder.Name, myFileName, SearchSubFolder​

Next​

End If​

End Sub

 

[Lequocvan]

Em sửa được rồi, hay quá. Em cám ơn tất cả nha.

Option Explicit
Private myN As Long
Private myFiles() As String

Sub Dat_ten_theo_Sheet()

myN = 0
SearchFiles "c:\data", "*.xls", True '<- True for search subfolder...
If myN > 0 Then
​

DoTheJob​

Else
​

MsgBox "No file found"​

End If​

End Sub

Sub DoTheJob()

Dim tenWsVBA, tenWs As String
Dim s As String
Dim path1 As String
Dim i As Long
For i = 1 To myN
With Workbooks.Open(myFiles(1, i) & "" & myFiles(2, i))
'.Sheets("Sheet1").Range("C12").Formula = ("Enter text here")

s = Sheets(1).Range("G1").Value
ActiveSheet.Name = s
path1 = ActiveWorkbook.Path


.SaveAs fileName:=path1 & "" & s & ".xls" _
​

, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _​

, CreateBackup:=False​

'MsgBox path1 & "" & s & ".xls"
'MsgBox "Hay xem lai!", vbOKOnly, "Bao loi"
'Exit Sub
.Close True
End With
Next
End Sub

Sub SearchFiles(ByVal myDir As String, ByVal myFileName As String, _
ByVal SearchSubFolder As Boolean)

Dim fso As Object, myFile As Object, myFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.GetFolder(myDir).Files
​

If myFile.Name Like myFileName Then
​

myN = myN + 1
ReDim Preserve myFiles(1 To 2, 1 To myN)
myFiles(1, myN) = myDir
myFiles(2, myN) = myFile.Name​

End If​

Next
If SearchSubFolder Then
​

For Each myFolder In fso.GetFolder(myDir).Subfolders
​

SearchFiles myDir & "" & myFolder.Name, myFileName, SearchSubFolder​

Next​

End If​

End Sub

 

[Lequocvan]

Em chạy được các ngày đến ngày 11 chạy thì code lỗi như sau, mong các thầy chỉ giúp ah?
Em hiểu nôm na, là khi tách các sheets bị trùng lặp, vậy ở phần code TachWs2File em chỉ muốn tách các sheets theo danh sách (HoiSo, PGDso03, PGDso04, PGDso07, PGDso09, PGDso10) thì sửa như thế nào được ah?

Sub TachWs2File()

On Error Resume Next
Dim tenWsVBA, tenWs As String
tenWsVBA = ActiveSheet.CodeName
tenWs = ActiveSheet.Name

With Application
​

.ScreenUpdating = 0
.EnableEvents = 0
.DisplayAlerts = 0
.Calculation = 3​

End With
Dim i As Long, MyName As Name
'For i = 3 To Sheets.Count
For i = 1 To Sheets.Count
Sheets(i).Copy
With ActiveWorkbook
With .Sheets(1)
​

.DrawingObjects.Delete​

.Cells.Copy​

.Cells.PasteSpecial 3​

.Range("A1").Select​

For Each MyName In .Names​

MyName.Delete​

Next​

tenWs = ActiveSheet.Name​

End With
With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With
.SaveAs FileName:="c:\Data" & "" & tenWs & "" & .Sheets(1).Name, FileFormat:=xlNormal
'.SaveAs Filename:="c:\fripcas" & "" & tenWs & "" & .Sheets(1).Name, FileFormat:=xlNormal
'.SaveAs Filename:=ThisWorkbook.Path & "" & .Sheets(1).Name, FileFormat:=xlNormal
'ActiveSheet.Name = Range("G2").value
.Close
End With
Next
With Application
.Calculation = 1
.DisplayAlerts = 1
.EnableEvents = 1
.ScreenUpdating = True
End With​

End Sub

 

[Lequocvan]

Dạ em cám ơn các Thầy ah, em làm được rồi, cũng nhờ code của Thầy Dụ ah.

 

[dhn46]

Kể cũng hay, chẳng thấy bài trả lời nào được tính là hữu ích, công sức những người tại topic này = công cốc

Chúc mừng năm mới!