Excel: Tự động tách và tạo thành nhiều file Excel theo tiêu chí bằng VBS

Cập nhật mới: Script cho Excel 2013, Excel 2016 (bên dưới)

(Anhgolden's Blog)- Trong trường hợp, ta có 1 file Excel dữ liệu tổng hợp, muốn tách và tạo ra nhiều file gồm dữ liệu tương ứng theo 1 tiêu chí cụ thể. Ví dụ theo từng đối tác, từng ngày, từng sản phẩm...

Lưu ý: Trong file dữ liệu tổng hợp sẽ gồm 1) Dòng trường dữ liệu (Header) và Phần bên trên - Phần này sẽ có ở tất cả các file được tách và 2) Phần dữ liệu (phần dữ liệu bên dưới Header) - Sẽ được tách dữ liệu. Có 1 Cột chọn làm tiêu chí phân tách, được Sort A to Z.

Lưu ý:
a) iColumn = [n] 'Chon cot can tach': Cột tiêu chí có thứ tự thứ [n] trong trường dữ liệu (Header).
b) iRow = [m] 'Chon dong bat dau tach': Dòng Header có thứ tự thứ [m] từ trên xuống.
c) Chương trình sẽ tạo thư mục có tên Output chứa các file sau khi tách. Có thể đổi tên thư mực Output tại dòng output = "Output" 'Doi ten o day

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

Xin cập nhật Mới Script cho Excel 2013, Excel 2016.

Ghi chú: Cần lưu ý 3 chỗ sau

iColumn = 2 'Chon cot can tach'
iRow = 9 'Chon dong header'
output = Format(DateTime.Now - 1, "ddMMyyyy") 'Doi ten o day

Sub Tachfile()
Dim iColumn As Integer
      iColumn = 2 'Chon cot can tach'
      iRow = 9 '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
        
        Set firstColumnOfRowP = ThisSheet.Cells(p, 2)
        If ("" = ThisSheet.Cells(p, 1)) Then
            Exit For
        End If
        
        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 = Format(DateTime.Now - 1, "ddMMyyyy") '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 & "\" & "Payoo_" & StrConv(myList.Item(p), 1) & "_" & Format(DateTime.Now - 1, "ddMMyyyy")
        
        wb.Close
      Next
      
      Application.ScreenUpdating = True
      Set wb = Nothing
End Sub