Sub DistributeRowsToNewWBS()
'auteur Norie
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Set wsData = Worksheets("Feuil1") ' name of worksheet with the data
Set wsCrit = Worksheets.Add
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
' column H has the criteria
wsData.Range("G1:G" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("H1"), Unique:=True
Set rngCrit = wsCrit.Range("H2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add
' change E to reflect columns to copy
wsData.Range("A1:G" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
wsNew.Name = rngCrit
wsNew.Copy
Set wbNew = ActiveWorkbook
' saves new workbook in path of existing workbook
wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit & ".xls"
wbNew.Close SaveChanges:=True
Application.DisplayAlerts = False
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("H2")
Wend
wsCrit.Delete
Application.DisplayAlerts = True
End Sub