Mình có lên mạng tìm và sử dụng được đoạn code, nhưng có 1 điểm là mình cần lưu lại những file excel 2k3 (code tự lưu với dạng 2k7)
Bạn nào rành về code có thể chỉnh sửa giúp mình nha.
Cám ơn nhiều.
[h=3]Tự động tách và tạo thành nhiều file Excel[/h]
Sub Tachfile()
Dim iColumn As Integer
iColumn = 1 'Chon cot can tach'
iRow = 5 'Chon dong header'
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
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, 1), ThisSheet.Cells(iRow, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A" & wb.Sheets(1).UsedRange.Rows.Count)
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), 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, 1), 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 ""'
Set fso = CreateObject("Scripting.FileSystemObject")
' Tao thu muc Output
Dim output As String
output = "Output" 'Doi ten o day
Dim exist As Boolean
exist = fso.FolderExists(ThisWorkbook.Path & "" & output)
If (exist = False) Then
Set f = fso.CreateFolder(ThisWorkbook.Path & "" & output)
End If
wb.SaveAs ThisWorkbook.Path & "" & output & "" & myList.Item(p) & "_" & Format(DateTime.Now, "yyyyMMddhhmm")
wb.Close
Next
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
Bạn nào rành về code có thể chỉnh sửa giúp mình nha.
Cám ơn nhiều.
[h=3]Tự động tách và tạo thành nhiều file Excel[/h]
Sub Tachfile()
Dim iColumn As Integer
iColumn = 1 'Chon cot can tach'
iRow = 5 'Chon dong header'
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
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, 1), ThisSheet.Cells(iRow, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A" & wb.Sheets(1).UsedRange.Rows.Count)
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), 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, 1), 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 ""'
Set fso = CreateObject("Scripting.FileSystemObject")
' Tao thu muc Output
Dim output As String
output = "Output" 'Doi ten o day
Dim exist As Boolean
exist = fso.FolderExists(ThisWorkbook.Path & "" & output)
If (exist = False) Then
Set f = fso.CreateFolder(ThisWorkbook.Path & "" & output)
End If
wb.SaveAs ThisWorkbook.Path & "" & output & "" & myList.Item(p) & "_" & Format(DateTime.Now, "yyyyMMddhhmm")
wb.Close
Next
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
