S
salgud
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 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.