Any body please help me.......

I would like to copy a range from an excel file (without any formula and
with the format) and paste on desktop as a new excel file.

For the above purpose I was using the below macro, but it is taking around 5
minutes to export this file to the desk top. Is there any other way to do so?

Is there any error on the below macro?

Kindly help on this matter.


Sub MacroEmailPOB()
Sheets("Email").Visible = True
Sheets("Email").Select

Cells.Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Columns("A:A").Select
Selection.ColumnWidth = 3.29
Columns("B:B").Select
Selection.ColumnWidth = 4.86
Columns("C:C").Select
Selection.ColumnWidth = 3.71
Columns("D").Select
Selection.ColumnWidth = 19.14
Columns("E:E").Select
Selection.ColumnWidth = 10.14
Columns("F:F").Select
Selection.ColumnWidth = 9.43
Columns("G:G").Select
Selection.ColumnWidth = 10
Columns("H:I").Select
Selection.ColumnWidth = 8.14
Columns("J:J").Select
Selection.ColumnWidth = 5.43

Sheets("CrewList").Select
Range("total").Select

Selection.Copy
Sheets("Email").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("D12").Select
ActiveWindow.SmallScroll Down:=-15
Range("A1").Select
Sheets("CrewList").Select
Application.CutCopyMode = False
Range("A1").Select
Sheets("Email").Select
Range("A1").Select
Sheets("Email").Select
Sheets("Email").Copy
ChDir "C:\Documents and Settings\radio\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\radio\Desktop\POB.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
ActiveWindow.SelectedSheets.Visible = False
Range("L7").Select
Sheets("CrewList").Select
Range("A1").Select

End Sub

I did not test this so it might hiccup. If so, post back and I'll fix it.
I basically just cleaned up the code by removing a lot of unneeded select
and selection verbiage.

Sub MacroEmailPOB()
Sheets("Email").Visible = True
With Sheets("Email")
.ClearContents
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With Sheets("Email")
.Columns("A:A").ColumnWidth = 3.29
.Columns("B:B").ColumnWidth = 4.86
.Columns("C:C").ColumnWidth = 3.71
.Columns("D").ColumnWidth = 19.14
.Columns("E:E").ColumnWidth = 10.14
.Columns("F:F").ColumnWidth = 9.43
.Columns("G:G").ColumnWidth = 10
.Columns("H:I").ColumnWidth = 8.14
.Columns("J:J").ColumnWidth = 5.43

Sheets("CrewList").Range("total").Copy
With Sheets("Email").Range("A1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With.
Application.CutCopyMode = False


ChDir "C:\Documents and Settings\radio\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\radio\Desktop\POB.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
ActiveWindow.edSheets.Visible = False .
Application.GoTo Sheets("CrewList").Range("A1").
End Sub




"RE: VLOOKUP fORMULA" <(E-Mail Removed)> wrote in
message news:C4DB5A19-E339-48BA-9542-(E-Mail Removed)...
> Any body please help me.......
>
> I would like to copy a range from an excel file (without any formula and
> with the format) and paste on desktop as a new excel file.
>
> For the above purpose I was using the below macro, but it is taking around
> 5
> minutes to export this file to the desk top. Is there any other way to do
> so?
>
> Is there any error on the below macro?
>
> Kindly help on this matter.
>
>
> Sub MacroEmailPOB()
> Sheets("Email").Visible = True
> Sheets("Email").Select
>
> Cells.Select
> Selection.ClearContents
> Selection.Borders(xlDiagonalDown).LineStyle = xlNone
> Selection.Borders(xlDiagonalUp).LineStyle = xlNone
> Selection.Borders(xlEdgeLeft).LineStyle = xlNone
> Selection.Borders(xlEdgeTop).LineStyle = xlNone
> Selection.Borders(xlEdgeBottom).LineStyle = xlNone
> Selection.Borders(xlEdgeRight).LineStyle = xlNone
> Selection.Borders(xlInsideVertical).LineStyle = xlNone
> Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
>
> Columns("A:A").Select
> Selection.ColumnWidth = 3.29
> Columns("B:B").Select
> Selection.ColumnWidth = 4.86
> Columns("C:C").Select
> Selection.ColumnWidth = 3.71
> Columns("D").Select
> Selection.ColumnWidth = 19.14
> Columns("E:E").Select
> Selection.ColumnWidth = 10.14
> Columns("F:F").Select
> Selection.ColumnWidth = 9.43
> Columns("G:G").Select
> Selection.ColumnWidth = 10
> Columns("H:I").Select
> Selection.ColumnWidth = 8.14
> Columns("J:J").Select
> Selection.ColumnWidth = 5.43
>
> Sheets("CrewList").Select
> Range("total").Select
>
> Selection.Copy
> Sheets("Email").Select
> Range("A1").Select
> Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
> SkipBlanks _
> :=False, Transpose:=False
> Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
> SkipBlanks:=False, Transpose:=False
> Range("D12").Select
> ActiveWindow.SmallScroll Down:=-15
> Range("A1").Select
> Sheets("CrewList").Select
> Application.CutCopyMode = False
> Range("A1").Select
> Sheets("Email").Select
> Range("A1").Select
> Sheets("Email").Select
> Sheets("Email").Copy
> ChDir "C:\Documents and Settings\radio\Desktop"
> ActiveWorkbook.SaveAs Filename:= _
> "C:\Documents and Settings\radio\Desktop\POB.xlsx", FileFormat:= _
> xlOpenXMLWorkbook, CreateBackup:=False
>
> ActiveWindow.Close
> ActiveWindow.SelectedSheets.Visible = False
> Range("L7").Select
> Sheets("CrewList").Select
> Range("A1").Select
>
> End Sub