This might work ok for you.
I did assume one row of headers.
Option Explicit
Sub testme2()
Application.ScreenUpdating = False
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim rng As Range
Dim myUniqueCells As Range
Dim myCell As Range
Dim myPath As String
myPath = "C:\my documents\excel\test"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If
Set curWks = Worksheets("sheet1")
With curWks
.AutoFilterMode = False
Set rng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set myUniqueCells = rng.Offset(1, 0) _
.Resize(rng.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
.ShowAllData
rng.AutoFilter
For Each myCell In myUniqueCells.Cells
rng.AutoFilter Field:=1, Criteria1:=myCell.Value
Set newWks = Workbooks.Add(1).Worksheets(1)
With rng
.SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=newWks.Range("a1")
End With
With newWks
On Error Resume Next
.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Error renaming " & .Name & " (for: " _
& myCell.Value & ")" & vbLf & _
"Please rename and save manually!"
Err.Clear
Else
Application.DisplayAlerts = False
On Error Resume Next
.Parent.SaveAs Filename:=myPath & .Name, _
FileFormat:=xlNormal
If Err.Number < 0 Then
MsgBox "Error saving " & .Name & vbLf _
& "Please save manually"
Err.Clear
Else
.Parent.Close savechanges:=False
End If
End If
On Error GoTo 0
End With
Next myCell
.ShowAllData
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
thang wrote:
Hello,
I have a list in one worksheet, the column A contains the
manager's name, the same manager is found in many
different lines of the list.
I want to copy lines with the same manager in another
workbook and save it with this manager's name.
How can I do it automatically (probably with VBA).
Please give me help for this matter and many thanks.
T
--
Dave Peterson