Unfortunately my desire outstrips my ability once again!
Can someone please help amending this code to do the following
Save any sheet not starting with an X to a new workbook and then delete it.
I'd like to be prompted as to where i'd like to save the files and enter a standard prefix which will sit infront of all the files when saved.
I've found two seperate pieces of code which do some or part but i need to knit them together and develope.
First for the prompt (courtsey of "Copy to new workbook")
and the second is
Any help thankfully received
Tarqs
Can someone please help amending this code to do the following
Save any sheet not starting with an X to a new workbook and then delete it.
I'd like to be prompted as to where i'd like to save the files and enter a standard prefix which will sit infront of all the files when saved.
I've found two seperate pieces of code which do some or part but i need to knit them together and develope.
First for the prompt (courtsey of "Copy to new workbook")
Code:
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
and the second is
Code:
Sub Export()
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
Folder = "Select the folder to save the workbooks"
Folder = GetDirectory(Folder)
If Folder = "" Then Exit Sub
Prefix = InputBox("Enter a prefix (or leave blank)")
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> Master Then
sh.Copy
Fname = Folder & "\" & Prefix & sh.Name & ".xls"
If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
Title:=Fname & " exists - select file to save as")
ActiveWorkbook.SaveAs Filename:=Fname
ActiveWorkbook.Close
End If
Next sh
Application.ScreenUpdating = True
End If
End Sub
Any help thankfully received
Tarqs