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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.