VBA Excel: automatically split data into multiple CSV files based on criteria






The Scenario: You have a massive dataset with a specific category column (e.g., Store Name, Employee ID, or Province). Your task is to split this master table into smaller parts, where each unique category is saved as a separate CSV file in your local folder.
What this code solves:
•Automatic unique list discovery: It automatically scans Column C to identify how many unique entities need to be exported—no manual input required.
•Filename sanitization: It automatically replaces "forbidden" Windows characters (such as / \ : ? *) with underscores to prevent crashes or errors during the saving process.

Sub ExportFilteredDataToCSV()
Dim ws As Worksheet
Dim newWorkbook As Workbook
Dim rng As Range
Dim cell As Range
Dim filterValues As Variant
Dim i As Long

Set ws = ActiveWorkbook.ActiveSheet
Set rng = ws.Range("C1:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)

filterValues = WorksheetFunction.Unique(rng)
i = UBound(filterValues, 1)
For i = 1 To i
filterValue = filterValues(i, 1)
rng.AutoFilter Field:=1, Criteria1:=filterValue
If WorksheetFunction.Subtotal(103, rng) > 1 Then
If filterValue <> ws.Range("C1").Value Then
Dim fileName As String
fileName = filterValue & ".csv"
fileName = Replace(fileName, "/", "_")
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, ":", "_")
fileName = Replace(fileName, "?", "_")
fileName = Replace(fileName, "*", "_")
fileName = Replace(fileName, "[", "_")
fileName = Replace(fileName, "]", "_")



Set newWorkbook = Workbooks.Add
With newWorkbook.Sheets(1)
ws.UsedRange.Offset(1).Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Columns.AutoFit

Application.DisplayAlerts = False
.SaveAs fileName:=ThisWorkbook.Path & "\" & fileName, FileFormat:=xlCSV
Application.DisplayAlerts = True
End With

newWorkbook.Close SaveChanges:=False
Set newWorkbook = Nothing
End If
End If

ws.AutoFilterMode = False
Next i

MsgBox "Export to CSV files completed!"
End Sub

Nhận xét