Macro to separate data from single worksheet to multiple worksheets

[EverClear]

Hi there!</SPAN>
I have a large amount of data that is all contained in a single worksheet. I am trying to create a macro to separate the data according to name in Column A, then place each block of data with a different name in column A in a separate worksheet in the same workbook. For example:

Col. A Col. B
112053 611150 - COORD MKTG & TRNG PRO
112053 611150 - COORD MKTG & TRNG PRO
112053 611150 - COORD MKTG & TRNG PRO
112053 611150 - COORD MKTG & TRNG PRO
112053 611150 - COORD MKTG & TRNG PRO
112053 611080 - PRINTING & GRAPHICS
112053 611315 - FREIGHT OTHER
125007 611695 - MEETINGS-MEALS
125007 619990 - Product Launch Cost
125007 619990 - Product Launch Cost
125007 619990 - Product Launch Cost
125007 611085 - AUDIO VISUAL COMMUNICATIONS
125007 611695 - MEETINGS-MEALS
125007 611705 - TRANSPORTATION
125007 619990 - Product Launch Cost
125007 619990 - Product Launch Cost
125007 611705 - TRANSPORTATION
125007 619990 - Product Launch Cost
700120 611010 - SUPPLIES
700120 611015 - SMALL TOOLS
700120 611025 - TELEPHONE
700120 611080 - PRINTING & GRAPHICS
700120 611290 - DUES SUBSCRIPT & PUBLICATIONS
700120 611315 - FREIGHT OTHER
700120 611355 - OTHER OPERATING EXPENSE
700120 611605 - MEETINGS

So - as the name in Col. A changes, I want to copy those blocks of data into separate worksheets in the same workbook. Here's the code I have so far:</SPAN>

Sub SplitData()
Dim DataMarkers(), Names As Range, name As Range, n As Long, i As Long</SPAN>
Set Names = Range("A2:A" & Range("A1").End(xlDown).Row)
n = 0</SPAN>

DeleteWorksheets </SPAN>'Deletes all worksheets apart from the one with the initial data table</SPAN>


For Each name In Names
If name.Offset(1, 0) <> name Then
ReDim Preserve DataMarkers
DataMarkers = name.Row
</SPAN>Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name </SPAN>'this is where it bombs out</SPAN>
n = n + 1
End If
Next name</SPAN>
For i = 0 To UBound(DataMarkers)
If i = 0 Then
Worksheets(1).Range("A2:M" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1")
Else
Worksheets(1).Range("A" & (DataMarkers(i - 1) + 1) & ":M" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1")
End If
Next i
End Sub</SPAN>


Sub DeleteWorksheets()
Dim ws As Worksheet, activeShtIndex As Long, i As Long</SPAN>
activeShtIndex = ActiveSheet.Index</SPAN>
Application.DisplayAlerts = False
For i = ThisWorkbook.Worksheets.Count To 1 Step -1
If i <> activeShtIndex Then
Worksheets(i).Delete
End If
Next i
Application.DisplayAlerts = True
End Sub</SPAN>


The code gives me a </SPAN>Run-time error: '1004.' </SPAN>Apparently there's a bug in my code that's causing the new worksheets to be named the same as an existing worksheet. But I can't seem to fix this.

Help!!</SPAN></SPAN>

 

[vavs]

It appears that you are trying to add a worksheet and rename it all at once. This has never worked for me. In fact it is impossible if you use a Mac. I usually add a worksheet and then use with activeworksheet.name = name

You may want to try that approach.