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