PDA

View Full Version : Exporting Spreadsheets



thomas.szwed
04-04-2008, 05:53 AM
Here I have some code that exports two worksheets from my workbook into a new worbook that can be named by the user using a input box. I am having problems copying both worksheets though with a 'Subscript out of Range' Error which is highlighting the second sheet (for archive) as where the error lies. Could anyone give me some code or alter mine so that i could export my two sheets without error?

Many Thanks


Sub NewStarterStats()
Dim msgResponse As String 'confirm delete
Application.ScreenUpdating = False

'get user confirmation
msgResponse = MsgBox("This will produce a statistics report for editing. Continue?", _
vbCritical + vbYesNo, "Archive Records")

Select Case msgResponse 'action dependent on response

Case vbYes

'Input box to name new file
newname = InputBox("Enter Filename", "Statistics Report", vbOKCancel)

If newname <> vbNullString Then

'Save it with the NewName and in the same directory as original
Worksheets("Master Data").Copy
Worksheets("For Archive").Copy
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & newname & ".xls"
ActiveWorkbook.Close SaveChanges:=False

Else

Exit Sub
End If

Case vbNo

Exit Sub

End Select

End Sub

thomas.szwed
04-04-2008, 08:35 AM
Can anybody help me?

Many Thanks!

georgiboy
04-04-2008, 09:57 AM
Here you go
Sub NewStarterStats()
Dim msgResponse As String 'confirm delete
Application.ScreenUpdating = False

'get user confirmation
msgResponse = MsgBox("This will produce a statistics report for editing. Continue?", _
vbCritical + vbYesNo, "Archive Records")

Select Case msgResponse 'action dependent on response

Case vbYes

'Input box to name new file
newname = InputBox("Enter Filename", "Statistics Report", vbOKCancel)

If newname <> vbNullString Then

'Save it with the NewName and in the same directory as original
Sheets(Array("Master Data", "For Archive")).Copy
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & newname & ".xls"
ActiveWorkbook.Close SaveChanges:=False

Else

Exit Sub
End If

Case vbNo

Exit Sub

End Select

End Sub

Hope this helps

thomas.szwed
04-07-2008, 01:51 AM
Thanks this works well. Do you know if there is anyway i can enter this code below to do its work on the new worbook we create in the "NewStarterStats" sub??

Sub Macro1()

Sheets("Master Data").Select

Range("A1:AC166").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

Sheets("For Archive").Select

ActiveSheet.Unprotect Password:="pastille"

Range("A1:AC133").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

Sheets("Master Data").Select

End Sub


This would be the final step. Thanks

thomas.szwed
04-07-2008, 06:01 AM
Can anybody help me pls! Thanks in Advance!

georgiboy
04-07-2008, 09:36 AM
Here you go
Sub NewStarterStats()
Dim msgResponse As String 'confirm delete
Application.ScreenUpdating = False

'get user confirmation
msgResponse = MsgBox("This will produce a statistics report for editing. Continue?", _
vbCritical + vbYesNo, "Archive Records")

Select Case msgResponse 'action dependent on response

Case vbYes

'Input box to name new file
Dim newname As String
newname = InputBox("Enter Filename", "Statistics Report", vbOKCancel)

If newname <> vbNullString Then

'Save it with the NewName and in the same directory as original
Sheets(Array("Master Data", "For Archive")).Copy

a = ThisWorkbook.Path & "\" & newname & ".xls"

With a

Sheets("Master Data").Select
Range("A1:AC166").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
Sheets("For Archive").Select
ActiveSheet.Unprotect Password:="pastille"
Range("A1:AC133").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
Sheets("Master Data").Select

ActiveWorkbook.SaveCopyAs a
ActiveWorkbook.Close False

End With
Else

Exit Sub
End If

Case vbNo

Exit Sub
End Select
End Sub
Hope this helps