Hi,
Give this a go,
Sub Button6_Click()
Dim LstRws As Long, Rng As Range, c As Range
With Application
.DisplayAlerts = False
.ScreenUpdating = False
LstRws = Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(Cells(2, 2), Cells(LstRws, 2))
For Each c In Rng.Cells
c.EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial
ActiveWorkbook.SaveAs Filename:="C:\TestFolder\" & c & " " & c.Offset(0, 1) & ".xls"
ActiveWorkbook.Close
Next c
.CutCopyMode = False
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Bookmarks