Done many copy/pastes before, but today, XL doesn't like it!
Sub AllocbyCty()
Dim wbCty As Workbook
Dim sNew As String
Dim lCurCol As Long
Dim wsSource As Worksheet
Dim wsTranspose As Worksheet
Dim sCty As String
Dim lStrDif As Long

Set wsSource = ActiveSheet

lCurCol = 2

wsSource.Range("A1").Select

Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

Selection.Copy
Sheets.Add.Activate
Set wsTranspose = ActiveSheet
wsTranspose.Name = "Transpose"

Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True

Do Until wsTranspose.Cells(1, lCurCol) = ""

sCty = wsTranspose.Cells(1, lCurCol)
lStrDif = Len(sCty) - 5
sCty = Right(sCty, Len(sCty) - lStrDif)
Range("A1:A4").Select
Selection.Copy
Workbooks.Add.Activate
Set wbCty = ActiveWorkbook
wbCty.SaveAs Filename:=ThisWorkbook.Path & "\" & sCty
Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlValues,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Any suggestions?
Thanks