mình ví dụ vậy thôi, vì file như vậy cũng nặng, mình có file 459 sheet nhưng dữ liệu của cty nên mình ko tiện gửi, sửa gửi lên thì cũng lâu, mình chỉ mắc chỗ code dừng để lấy 50 sheet lưu ra 1 file excel, sau đó lại lấy tiếp 50 sheet tiếp theo để lưu tiếp ra file thứ 2.,,..
Mình không có nhu cầu lên không làm file ví dụ để thử.
Option Explicit
Sub Tach_File_Vidu_1000_Sheet()
Dim fso As Object, book As Workbook, sFolder As String, file1000sheet As String
Set fso = CreateObject("Scripting.FileSystemObject")
file1000sheet = "D:\DuLieuABC\file1000sheet.xlsx"
If Not fso.FileExists(file1000sheet) Then
MsgBox "Khong tim thay file 1000 sheet!", vbCritical: Exit Sub
End If
sFolder = Application.DefaultFilePath & "\"
Set book = Workbooks.Open(file1000sheet)
splitSheetToWorkbook book, sFolder, 50
book.Close False
MsgBox "Da tach xong, cac file tach ra duoc luu o thu muc: " & vbNewLine & sFolder, vbInformation
End Sub
Sub splitSheetToWorkbook(ByVal book As Workbook, ByVal strPath As String, soSheet As Integer)
Dim newWB As Workbook, ws As Worksheet, strFileName As String
Dim SheetCount As Integer, i As Integer, j As Integer, TotalSheet As Integer
TotalSheet = book.Sheets.Count
For i = 1 To TotalSheet Step soSheet
j = i + soSheet - 1
If j > TotalSheet Then j = TotalSheet
strFileName = "split__" & Format(Now, "yyMMdd hhmmss") & "__" & Format(i, "000") & "-" & Format(j, "000") & ".xlsx"
Set newWB = Workbooks.Add(xlWBATWorksheet)
newWB.SaveAs FileName:=strPath & strFileName
SheetCount = 1
For Each ws In book.Worksheets
If SheetCount >= i And SheetCount <= j Then
ws.Copy After:=newWB.Sheets(newWB.Sheets.Count)
End If
SheetCount = SheetCount + 1
Next ws
newWB.Sheets(1).Delete
newWB.Save: newWB.Close
Next i
End SubMình cám ơn bạn nhiều nhé. Mình muốn hỏi thêm bạn giờ mình có 50 nhà cung cấp , mình muốn ghép 50 file excel này vào thành 1 file và mỗi nhà cung cấp là 1 sheet trong file đó. Mình tìm trên mạng thì chủ yếu là file excel gộp thành 1 sheet tổng hợp trong file chứ ko có tách riêng từng sheet. Bạn giúp mình với. CHÀO
Bạn tham khảo . .
Option Explicit
Sub Gop_50_nha_cung_cap()
Dim fso As Object, sourceFolder As Object, FileItem As Object
Dim newWorkbook As Workbook, openWorkbook As Workbook, ws As Worksheet
Dim sName As String, sFileName As String, sFolder As String
sFolder = "D:\File"
Set fso = CreateObject("Scripting.FileSystemObject")
Set sourceFolder = fso.GetFolder(sFolder)
Set newWorkbook = Workbooks.Add
For Each FileItem In sourceFolder.Files
sName = FileItem.Name
If sName Like "*.xls*" Then
Set openWorkbook = Workbooks.Open(FileItem.Path)
For Each ws In openWorkbook.Worksheets
ws.Copy After:=newWorkbook.Sheets(newWorkbook.Sheets.Count)
Next ws
openWorkbook.Close False
End If
Next FileItem
newWorkbook.SaveAs Filename:=Application.DefaultFilePath & "\Merged___" & Format(Now, "yyMMdd hhmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
'newWorkbook.Close
MsgBox "Kêt thúc.", vbInformation
End SubCảm ơn @befaint đã chỉ dẫn , đúng là ban đầu OT có nghĩ đến vấn đề này nhưng trước đó OT đã thử làm tay nếu trùng tên sheet thì Excel tự động thêm số trong ngoặc để khác tên.Chèn sheet vào phải kiểm tra sự tồn tại tên của nó đã chứ.
Nếu nó trùng phải làm sao nghĩ ra cái tên không trùng với các tên đã có, khúc này mới hay.
Cảm ơn bạn, với kỹ thuật cao siêu này OT chưa biết đến, nếu có thể phiền bạn cho OT cách làm hoàn chỉnh với ạ, hi vọng OT có mở mang thêm được chút ít.
Public Sub ResetApplicationSettings(ByVal bl As Boolean)
Application.ScreenUpdating = bl
Application.Calculation = bl
Application.DisplayAlerts = bl
Application.Calculation = IIf(bl, xlCalculationAutomatic, xlCalculationManual)
End Sub
Sub MergeExcelFiles()
ResetApplicationSettings False
On Error GoTo ErrorHandler
Dim wsNameDict As Object, FSO As Object, sourceFolder As Object, fileItem As Object
Dim currentWorkbook As Workbook, sourceWorkbook As Workbook
Dim sourceSheets() As Worksheet, ws As Variant
Dim newFilePath As String, wsName As String, bookName As String, folderPath As String
Dim wsNum As Integer, wsExist As Boolean
folderPath = "C:\supplierFile"
Set wsNameDict = CreateObject("Scripting.Dictionary")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sourceFolder = FSO.GetFolder(folderPath)
Set currentWorkbook = Workbooks.Add
For Each ws In currentWorkbook.Worksheets
wsNameDict.Add ws.Name, 1
Next ws
For Each fileItem In sourceFolder.Files
bookName = fileItem.Name
If bookName Like "*.xls*" Then
Set sourceWorkbook = Workbooks.Open(fileItem.Path)
ReDim sourceSheets(1 To sourceWorkbook.Worksheets.Count) As Worksheet
For Each ws In sourceWorkbook.Worksheets
Set sourceSheets(ws.Index) = ws
Next ws
For Each ws In sourceSheets
If Not ws Is Nothing Then
wsExist = wsNameDict.Exists(ws.Name)
wsName = ws.Name: wsNum = 1
While wsExist
wsName = ws.Name & "_" & wsNum
wsNum = wsNum + 1
wsExist = wsNameDict.Exists(wsName)
Wend
ws.Copy After:=currentWorkbook.Sheets(currentWorkbook.Sheets.Count)
currentWorkbook.Sheets(currentWorkbook.Sheets.Count).Name = wsName
wsNameDict.Add wsName, 1
End If
Next ws
sourceWorkbook.Close False
End If
Next fileItem
bookName = "MergedFiles__" & Format(Now, "yyMMdd hhmmss") & "__.xlsx"
newFilePath = FSO.BuildPath(folderPath, bookName)
currentWorkbook.SaveAs Filename:=newFilePath, FileFormat:=51
currentWorkbook.Close SaveChanges:=False
ResetApplicationSettings True
MsgBox "The process has finished, please check the " & bookName & " file in the " & folderPath, vbInformation, "MergedFiles"
Exit Sub
ErrorHandler:
ResetApplicationSettings True
MsgBox Err.Description, vbCritical, "ErrorNumber:" & Err.Number
End Sub
