VBA worked and now doesnt

[Andrewryan3]

I pulled this VBA off of Mr. Excel a week or so ago and it worked initially. After day 1, it no longer works (actually crashed my system) It was like it locked it all up. I tried to debug it and it seems like it is caught and just keeps looping .

Can someone take a look at it and see if there is anything that you see wrong?

Sub columntosheets()
Const sname As String = "Initial dump"
Const s As String = "C"
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).SORT .Cells(cc), 2, Header:=xlYes
On Error Resume Next
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub


Thanks so very much! I love this website.

 

[Norie]

What's the code meant to do?

 

[Andrewryan3]

What's the code meant to do?

This code is meant to sort a spreadsheet based on a name in a column and then place that on a different sheet. Initially it created 52 new sheets with the names as tab labels. I needed to test it again with the same information, I reran the VBA and was running for a very long time...I stopped it and it was looping on this part:

, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If

James