Sub CreateNewShtsTransferData() Dim lr As Long, x As Long Dim ID As Object Dim key As Variant Dim sht As Worksheet Dim ws As Worksheet Set sht = Sheet1 Set ID = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False Application.DisplayAlerts = False lr = sht.Range("A" & Rows.Count).End(xlUp).Row For x = 2 To lr If Not ID.Exists(sht.Range("A" & x).Value) Then ID.Add sht.Range("A" & x).Value, 1 End If Next x For Each key In ID.keys If Not Evaluate("ISREF('" & key & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key End If Set ws = Worksheets(CStr(key)) '---->This converts the vehicle numbers to text values otherwise the code will error. sht.Range("A1:A" & lr).AutoFilter 1, key sht.[A1].CurrentRegion.Copy ws.[A1] ws.Columns.AutoFit sht.[A1].AutoFilter Next key sht.Select Application.CutCopyMode = False Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "All done!", vbExclamation End Sub
DON'T MISS
It works and its really fast, please make me your student :)