Select a file and save it in a different location

[Oggy]

Hi

I am trying to write a code that allows me to select a file and save
it in a different location, and then delete the orginal file. I have
the following code, that does not work, i think i may be over
complicating it. Please Help!




Sub remove FileName()
Dim Filt As String
Dim FilterIndex As Integer
Dim FileName As Variant
Dim Title As String

' Set up list of file filters
Filt = "Text Files (*.txt),*.txt," & _
"Lotus Files (*.prn),*.prn," & _
"Comma Separated Files (*.csv),*.csv," & _
"ASCII Files (*.asc),*.asc," & _
"All Files (*.*),*.*"

' Display *.* by default
FilterIndex = 5

' Set the dialog box caption
Title = "Select a File to move"


' set directory
Chdir H:\OPEN ORDERS

' Get the file name
FileName = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)

' Exit if dialog box canceled
If FileName = False Then
MsgBox "No file was selected."
Exit Sub
End If
WorkBook.Open filename: .selecteditems(1)

If Val(Application.Version) < 10 Then
MsgBox "This requires Excel 2002 or later.", vbCritical
Exit Sub
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a location for the PO"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Canceled"
Else
WorkBook.SaveAs .SelectedItems(1)
End If
End With


Chdir H:\OPEN ORDERS

Kill .selecteditems(1)


End Sub

 

[cjakeman]

Hi

I am trying to write a code that allows me to select a file and save
it in a different location, and then delete the orginal file. I have
the following code, that does not work.

Oggy, you don't say in what way your code fails. Here is the code I
use for this on Excel 2000/2003.

Hope that helps, Chris

Public Sub RenameWorkbook()
Dim Reply As Variant
Dim OldName As String

OldName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
Reply = Application.GetSaveAsFilename(InitialFileName:=OldName, _
fileFilter:="Workbooks (*.xls), *.xls")

If Reply = False Then Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Reply
On Error Resume Next ' Kill might fail if a new workbook and
never saved or read-only
Kill OldName
Application.DisplayAlerts = True
End Sub