Giúp cách tách 1 file thành nhiều file bằng VBA có phần mở rộng là xls (1 người xem)

[locdx]

Mình đã thực hiện được việc tách 1 file excel thành nhiều file excel có cấu trúc giống nhau nhưng file tách ra lại có phần mở rộng là xlsx trong khi chương trình phần mềm chỉ chấp nhận file có phần mở rộng là xls.

Nhờ mọi mọi người hỗ trợ mình chỉnh sửa code VBA nay để file tách ra có phần mở rộng là xls. Xin chân thành cảm ơn !

Sub Tachfile()
Dim iColumn As Integer
iColumn = 1 'Chon cot can tach'
iRow = 8 'Chon dong bat dau tach'
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim WorkbookCounter As Integer
Dim Temp As String
Set myRangeToCopy = CreateObject("System.Collections.ArrayList")
Set myList = CreateObject("System.Collections.ArrayList")
Set myListWb = CreateObject("System.Collections.ArrayList")
Application.ScreenUpdating = False
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count - 1
WorkbookCounter = 1
For p = iRow + 1 To ThisSheet.UsedRange.Rows.Count Step 1
Dim isExist As Boolean
isExist = False
Dim iCount As Integer
For iCount = 0 To myList.Count - 1 Step 1
Set strTest = ThisSheet.Cells(p, iColumn)
If (myList.Item(iCount) = ThisSheet.Cells(p, iColumn)) Then
isExist = True
Exit For
End If
Next
If (isExist = False) Then
Set wb = Workbooks.Add
myListWb.Add wb
myList.Add ThisSheet.Cells(p, iColumn)
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(1, 2), ThisSheet.Cells(iRow, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A" & wb.Sheets(1).UsedRange.Rows.Count)
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 2), ThisSheet.Cells(p, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A" & wb.Sheets(1).UsedRange.Rows.Count + 1)
Else
Set wb = myListWb.Item(iCount)
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 2), ThisSheet.Cells(p, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A" & wb.Sheets(1).UsedRange.Rows.Count + 1)
End If
Next p
Workbooks.Application.DisplayAlerts = False
For p = 0 To myListWb.Count - 1 Step 1
Set wb = myListWb.Item(p)
For iColumn = 1 To 45 Step 1
wb.Worksheets("Sheet1").Columns(iColumn).ColumnWidth = ThisSheet.Columns(iColumn).ColumnWidth
Next
'wb.SaveAs ThisWorkbook.Path & "\Current\" & myList.Item(p)'
'Tao thu muc chua cac file da tach, mac dinh "\"'
wb.SaveAs ThisWorkbook.Path & "\" & myList.Item(p) & "_" & Format(DateTime.Now, "yyyyMMddhhmm")
wb.Close
Next
Application.ScreenUpdating = True
Set wb = Nothing
End Sub

 

[nhk007dn]

add-ins của anh ndu, bạn muốn tách kiểu gì cũng đc.
Vào http://www.giaiphapexcel.com/forum/...e-save-as-sheet-hiện-hành&p=531279#post531279 tải về dùng ko khỏe hơn sao bạn.
Chúc vui!

 

[locdx]

add-ins của anh ndu, bạn muốn tách kiểu gì cũng đc.
Vào http://www.giaiphapexcel.com/forum/...e-save-as-sheet-hiện-hành&p=531279#post531279 tải về dùng ko khỏe hơn sao bạn.
Chúc vui!

Cảm ơn bạn đã hỗ trợ nhưng cái add-in của bác ndu này ko áp dụng vào nhu cầu của mình được. Lý do: là file tách ra phải đánh tên.

Cái mình cần ở đây là:
1/ Từ file tổng hợp trên sẽ tách thành các file độc lập (worksheet độc lập).
2/ Tên file tách ra sẽ lấy dữ liệu cột đầu tiên làm tên với phần mở rộng là xls chứ không phải là xlsx.

Cụ thể là file sẽ như các file đính kèm.

 

[locdx]

Các cao thủ giúp mình với