Excel: Tự động tách và tạo thành nhiều file Excel theo tiêu chí bằng VBS
(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.
Xin chia sẽ đoạn VBS bên dưới hoặc có thể download tại đây.
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) wb.SaveAs ThisWorkbook.Path & "" & myList.Item(p) & "_" & Format(DateTime.Now, "yyyyMMddhhmm"): Phần này liên quan đến việc đặt tiên file gồm Tiêu chí phân tách và Datetime tạo file
Sub Tachfile()Dim iColumn As Integer iColumn = 1 'Chon cot can tach' iRow = 5 '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 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 ""' wb.SaveAs ThisWorkbook.Path & "" & myList.Item(p) & "_" & Format(DateTime.Now, "yyyyMMddhhmm") wb.Close Next Application.ScreenUpdating = True Set wb = NothingEnd Sub