The code below runs fine until it gets to the last pastespecial, the I get
the message "PasteSpecial of Range object failed". Any ideas?

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
Range("A1:A4").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 <---------- PasteSpecial failed

wsTranspose.Cells(1, lCurCol).Copy

wbCty.Activate
Range("B1").Select
ActiveSheet.Paste
lCurCol = lCurCol + 1
Loop
End Sub

Thanks as always.

You may want to change it to

wbCty.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlValues,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Just a guess.
--
HTH,
Barb Reinhardt



"salgud" wrote:

The code below runs fine until it gets to the last pastespecial, the I get
the message "PasteSpecial of Range object failed". Any ideas?

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
Range("A1:A4").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 <---------- PasteSpecial failed

wsTranspose.Cells(1, lCurCol).Copy

wbCty.Activate
Range("B1").Select
ActiveSheet.Paste
lCurCol = lCurCol + 1
Loop
End Sub

Thanks as always.

The problem is that you created and saved a workbook between your copy
and paste operations. This cancelled your copy, so there was nothing to
paste special. Just move your copy command down below where you save the
destination workbook. You'll then need to qualify it with a reference to the
worksheet you're copying from or it will try to copy from the new workbook
you just created.

--
Rob Bovey, Excel MVP
Application Professionals
http://www.appspro.com/

* Take your Excel development skills to the next level.
* Professional Excel Development
http://www.appspro.com/Books/Books.htm

"salgud" wrote in message
...
The code below runs fine until it gets to the last pastespecial, the I get
the message "PasteSpecial of Range object failed". Any ideas?

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
Range("A1:A4").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 <---------- PasteSpecial failed

wsTranspose.Cells(1, lCurCol).Copy

wbCty.Activate
Range("B1").Select
ActiveSheet.Paste
lCurCol = lCurCol + 1
Loop
End Sub

Thanks as always.