Loop optimization/Customization - excel

Question

The excel file I have is more than 1,000,000 rows and 26 columns.
Below is the code which is used to find a particular data and a new file is created on the basis of that data and currently it is taking around 15 mins to create a new file
Please if any expert can help me in processing the below macro faster.
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
strColumnValue = "1021 VDDGC 104"
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'Create a new Excel workbook
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.Rows(1).EntireRow.Copy
objSheet.Activate
objSheet.Range("A1").Select
objSheet.Paste
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range("K" & nRow).Value) = CStr(varColumnValue) Then
'Copy data with the same column "B" value to new workbook
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).Select
objSheet.Paste
objSheet.Columns("A:S").AutoFit
End If
Next
Next
End Sub

Answer 1

Copy Worksheet to a New Workbook
Copies (exports) the worksheet to a new workbook.
Sorts by and filters the criteria column.
Deletes the filtered rows.
Sub SplitWorksheetData()
Dim dt As Double: dt = Timer
Const Criteria As String = "1021 VDDGC 104"
Const CriteriaColumnIndex As Long = 2
Dim sws As Worksheet: Set sws = ActiveSheet ' improve!
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
If Not dict.Exists(Criteria) Then dict.Add Criteria, 1
Application.ScreenUpdating = False
Dim dwb As Workbook
Dim dws As Worksheet
Dim Key As Variant
For Each Key In dict.Keys
sws.Copy
Set dwb = Workbooks(Workbooks.Count)
Set dws = dwb.Worksheets(1)
If dws.FilterMode Then dws.ShowAllData
Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion
Dim ddrg As Range: Set ddrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
drg.Sort drg.Columns(CriteriaColumnIndex), xlAscending, , , , , , xlYes
drg.AutoFilter CriteriaColumnIndex, "<>" & Criteria
Dim vrg As Range
On Error Resume Next
Set vrg = ddrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
dws.AutoFilterMode = False
If Not vrg Is Nothing Then vrg.Delete
' Save code goes here...
'dwb.SaveAs...
Next Key
Application.ScreenUpdating = True
Debug.Print Timer - dt
MsgBox "Workbook created.", vbInformation
End Sub