optimize for 1M row:
```
Sub ExportByColumn_Fast_DynamicColumns()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim savePath As String
    Dim dataArr As Variant
    Dim headerArr As Variant
    Dim dictKeys As Object
    Dim key As Variant
    Dim i As Long, j As Long
    Dim filteredRows As Collection
    Dim rowIdx As Long
    Dim newWb As Workbook
    Dim outputArr As Variant
    Dim filterCol As Long
    
    filterCol = 10
    
    ' Speed optimization
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1) ' Adjust if needed
    
    ' Determine data extents
    lastRow = ws.Cells(ws.Rows.Count, filterCol).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    If lastRow < 2 Or lastCol < 1 Then
        MsgBox "No data found."
        GoTo Cleanup
    End If
    
    savePath = wb.Path & "\"
    If savePath = "\" Then
        MsgBox "Please save the current workbook first."
        GoTo Cleanup
    End If
    
    ' Load entire data into array
    headerArr = ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol)).Value ' Headers
    dataArr = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).Value
    
    ' Build dictionary of unique keys in column filterCol
    Set dictKeys = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(dataArr, 1)
        key = dataArr(i, filterCol)
        If Not dictKeys.Exists(key) Then
            dictKeys.Add key, True
        End If
    Next i
    
    ' For each unique key, filter data in memory
    For Each key In dictKeys.Keys
        Set filteredRows = New Collection
        For i = 1 To UBound(dataArr, 1)
            If dataArr(i, filterCol) = key Then
                filteredRows.Add i
            End If
        Next i
        
        If filteredRows.Count > 0 Then
            ' Prepare array for output
            ReDim outputArr(1 To filteredRows.Count + 1, 1 To lastCol)
            ' Copy headers
            For j = 1 To lastCol
                outputArr(1, j) = headerArr(1, j)
            Next j
            
            ' Copy filtered data
            For i = 1 To filteredRows.Count
                rowIdx = filteredRows(i)
                For j = 1 To lastCol
                    outputArr(i + 1, j) = dataArr(rowIdx, j)
                Next j
            Next i
            
            ' Create new workbook and paste data
            Set newWb = Workbooks.Add
            With newWb.Sheets(1)
                .Range("A1").Resize(UBound(outputArr, 1), UBound(outputArr, 2)).Value = outputArr
                .Columns.AutoFit
            End With
            
            ' Save workbook
            On Error Resume Next
            newWb.SaveAs fileName:=savePath & wb.Name & "_" & CleanFileName(CStr(key)) & ".xlsx", FileFormat:=51
            If Err.Number <> 0 Then
                MsgBox "Error saving file: " & savePath & wb.Name & "_" & CleanFileName(CStr(key)) & ".xlsx"
                Err.Clear
            End If
            newWb.Close SaveChanges:=False
            On Error GoTo 0
        End If
    Next key
    
    MsgBox "Export completed!"
    
Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Function CleanFileName(fileName As Variant) As String
    Dim arrForbidden As Variant
    Dim ch As Variant
    Dim strName As String
    
    strName = CStr(fileName)
    arrForbidden = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    
    For Each ch In arrForbidden
        strName = Replace(strName, ch, "_")
    Next ch
    
    CleanFileName = strName
End Function

```