I have used the below code to a workbook (SaveAs) and then delete the original file.
The Windows OS put the new created file on the first left vacant space on My Desktop.
What I need after using SaveAs , is to move it’s icon to the same old position of the original file on my Desktop.
Meaning, If my file is initially placed on the upper right of my desktop , I want to keep it in that location after using SaveAs.
In advance, appreciate for your time to help.
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim FilePath As String, wb As Workbook, FolderPath As String
Dim oldName As String, newName As String
Set wb = ThisWorkbook
FilePath = wb.FullName
FolderPath = wb.Path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs FolderPath & newName
Kill FilePath 'delete orginal file
Application.DisplayAlerts = True
End Sub
Please, also try this code. It uses classical Windows behavior. VBA writes a VBScript, creates the file and runs it. The script finds the open Excel session, the workbook in discussion, save, close it, quits Excel application in certaing circumstances and changes the workbook name only after that (keeping the same file icon position). Finally, the script kills itself:
Sub SaveAndChangeActiveWorkbookName_VBScript()
Dim vbsStr As String, fso As Object, vbsObj As Object, strVBSPath As String
Dim newName As String, wb As Workbook, ext As String, searchName As String
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, ".")))
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1))
End With
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
strVBSPath = ThisWorkbook.Path & "\Rename.vbs" 'the fullname of the VBScript to be created and run
vbsStr = "Dim objExcel, wb, objFile, FSO, fullName" & vbCrLf & _
"Set objExcel = GetObject(, ""Excel.Application"")" & vbCrLf & _
"Set FSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
" Set wb = objExcel.Workbooks(""" & ThisWorkbook.Name & """)" & vbCrLf & _
"fullName = wb.FullName" & vbCrLf & _
"wb.Close True" & vbCrLf & _
"If objExcel.Workbooks.Count = 0 Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
"ElseIf objExcel.Workbooks.Count = 1 Then" & vbCrLf & _
" If not UCase(Workbooks(1).Name) = ""PERSONAL.XLSB"" Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
" End If" & vbCrLf & _
"End If" & vbCrLf & _
"Set objFile = FSO.GetFile(fullName)" & vbCrLf & _
"objFile.Name = """ & newName & """" & vbCrLf & _
"FSO.DeleteFile Wscript.ScriptFullName, True" 'kill itself...
Set fso = CreateObject("Scripting.FileSystemObject")
Set vbsObj = fso.OpenTextFile(strVBSPath, 2, True)
vbsObj.Write vbsStr 'write the above string in the VBScript file
vbsObj.Close
Shell "cmd.exe /c """ & strVBSPath & """", 0 'execute/run the VBScript
End Sub
The next version tries simplifying your code, not needing any API:
Sub SaveAndChangeActiveWorkbookName_ShellAppl()
Dim sh32 As Object, oFolder As Object, oFolderItem As Object, wb As Workbook
Dim newName As String, ext As String, searchName As String
Set sh32 = CreateObject("Shell.Application")
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, "."))) 'extract extension
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1)) 'extract the rest of its name
newName = searchName & WorksheetFunction.RandBetween(5, 20) & _
IIf(showExtension, "." & ext, "") 'it sets correct new name...
.Save
.ChangeFileAccess xlReadOnly '!
Set oFolder = sh32.Namespace(.Path & "\")
Set oFolderItem = oFolder.ParseName(.Name)
oFolderItem.Name = newName
If (UCase(Workbooks(1).Name) = "PERSONAL.XLSB" _
And Workbooks.Count = 2) Or Workbooks.Count = 1 Then
Application.Quit
Else
.Close False 'no need to save it again and it closes faster in this way...
End If
End With
End Sub
'Function to check how 'Hide extension for known file type' is set:
Function showExtension() As Boolean
Dim fileExt As String, Shl As Object, hideExt As Long
fileExt = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt"
Set Shl = CreateObject("WScript.Shell")
hideExt = Shl.RegRead(fileExt)
If hideExt = 0 Then showExtension = True
End Function
I've been educated that Windows does not allow changing name of an open workbook. Which is true, you cannot do it manually. Windows does not let you do it, this is its philosophy to avoid data loss.
But setting ReadOnly file attribute looks to temporarily remove the file full name from the Windows File Allocation Table. If you try Debug.Print wb.FullFileName before and after changing its attribute, it will show the same (old) one. But it looks that there are ways to do it and letting the open workbook outside the Allocation Table, you can change its name. I did not even imagine this is possible and I consider that this is the most important issue I learned today.
Intro: Windows OS saves the positions of desktop icons somewhere in registry or another location.
When I post my question, I thought the answer will depend on extracting coordinates of (SavedAs workbook icon) on my desktop,
And then using an API method to place it on the old location of the original file.
But , It looks hard for VBA programmers.
So, I tried the idea of #Daniel Dušek :
(The idea was to SaveAs with the original file name which will just overwrite the old file and then rename it instead of deleting).
The idea itself is excellent, But using native VBA methods (Name and FileSystemObject. MoveFile) ,
have a possible behavior to move the file beside renaming and I need to imitate how Windows OS works when it rename a file (like when you use right-click and choose Rename),
and also, I cannot rename the open workbook by using (Name and FSO. MoveFile) even after set ChangeFileAccess to xlReadOnly.
But, with using native OS API , you can do much more than you can imagine.
I have got a sophisticated API to Rename Link by the professional #Siddharth Rout
The advantage of this API is you can rename a workbook while it is still open (sure after Change File Access to xlReadOnly) 😊.
Now, All works correctly as expected, and I can SaveAs a file keep it’s icon on desktop at the same old position of the original file.
Sub SaveAs_and_Rename_Me_Automatically()
Dim wb As Workbook, filePath As String, folderPath As String
Dim oldName As String, newName As String, ext As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.Path & "\"
oldName = fso.GetBaseName(filePath)
ext = fso.GetExtensionName(filePath)
newName = oldName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Application.DisplayAlerts = False
wb.SaveAs folderPath & oldName 'SaveAs with orginal name (just overwrite)
wb.ChangeFileAccess xlReadOnly 'change file access to Read_Only:
SHRenameFile filePath, folderPath & newName 'to rename the Workbook while it is still open!
Application.DisplayAlerts = True
If Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close SaveChanges:=True
End If
End Sub
And this the great API to rename:
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPtr
Private Const FOF_SIMPLEPROGRESS = &H100
Private Const FO_RENAME = &H4
Private Type SHFILEOPSTRUCT
hWnd As LongPtr
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As LongPtr
sProgress As String
End Type
Public Sub SHRenameFile(ByVal strSource As String, ByVal strTarget As String)
Dim op As SHFILEOPSTRUCT
With op
.wFunc = FO_RENAME
.pTo = strTarget
.pFrom = strSource
.fFlags = FOF_SIMPLEPROGRESS
End With
SHFileOperation op '~~> Perform operation
End Sub
a bit hacky setup but works, the idea is following:
save workbook with the suffix "to_del"
from that temp file we rename the original file
save the workbook as the renamed file
delete "to_del" file from the original file
the code:
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim filePath As String
Dim folderPath As String
Dim oldName As String
Dim newName As String
Dim wb As Workbook
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs Filename:=folderPath & newName & "_to_del.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Name folderPath & oldName As folderPath & newName & ".xlsm"
wb.SaveAs Filename:=folderPath & newName & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Kill folderPath & newName & "_to_del.xlsm"
Application.DisplayAlerts = True
End Sub
You do not say anything...
I have something to do in the next time interval, so I prepared a workaround, but working code based on my comment to your answer assumption, respectively:
A workbook named as the one keeping the code, only having a different numeric suffix before its extension, must exist on Desktop, like reference for the place where the other workbook to be placed;
Your code creates a new workbook, with a random (new) suffix.
ThisWorkbook is saved overwriting the existing workbook on Desktop, but using SaveCopyAs, to let the original workbook open and the overwitted workbook to be renamed (not being open):
Private Sub testSaveCopyAsOverwrite()
'References:
'Microsoft Shell Controls And Automation '(C:\Windows\System32\Shell32.dll)
Dim oShell As Shell32.Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim filePath As String, initFileName As String, newFileName As String, wb As Workbook
Dim thisName As String, newName As String, ext As String, searchName As String
filePath = "C:\Users\Fane Branesti\OneDrive\Desktop\"
Set wb = ThisWorkbook
thisName = wb.name
ext = Split(thisName, ".")(UBound(Split(thisName, ".")))
searchName = left(thisName, Len(thisName) - (Len(ext) + 1))
RecreateName: 'for the case when RandBetween returns the same name suffix...
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Set oShell = New Shell32.Shell
initFileName = Dir(filePath & searchName & "*." & ext) 'find the file to be overwriten
If initFileName <> "" Then
If newName = initFileName Then GoTo RecreateName 'if RandBetween returned the same suffix...
ThisWorkbook.SaveCopyAs fileName:=filePath & initFileName 'overwrite the existing workbook, but keeping the original wb open
Set oFolder = oShell.NameSpace(filePath)
Set oFolderItem = oFolder.ParseName(initFileName)
oFolderItem.name = newName 'change the initial file name with the necessary one, without moving it!
Else
MsgBox "No any workbook having the name pattern as: """ & filePath & searchName & """*." & ext & """"
End If
End Sub
Please, take care to add the required reference (from C:\Windows\System32\Shell32.dll) before running it...
In fact, you can run the next code to add it:
Sub addShellControlsAndAutomation()
'Add a reference to 'Microsoft Shell Controls And Automation':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.vbE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\Shell32.dll"
If err.number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "'Microsoft Shell Controls And Automation' reference already added...", vbInformation, _
"Reference already existing"
End If
On Error GoTo 0
End Sub
I already set the path and filename in a variable.
How to close the workbook using the filename that i already set?
This is the code:
Sub CLOSE_WORKBOOK_RAW()
Dim x As String
x = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
Dim Filepath As String
Filepath = ThisWorkbook.Path
Dim Filename As String
Filename = Filepath & "\" & x & ".xlsx"
Dim Filename2 As String
Filename2 = Filepath & "\" & x & ".xlsm"
Workbooks(Filename).Close Savechanges:=True
End Sub
The short of your code appears to be embraced in
ThisWorkbook.Close Savechanges:=True
All the rest of it just confuses the issue. However, here is the syntax for constructing a file name if, for example, you want to save the active workbook, usually while it is other than ThisWorkbook.
Sub Close_Workbook_Raw()
Dim Filepath As String ' the path to save at
Dim Filename As String ' the file's name
Dim Ext As String ' the file name extension
Filepath = ThisWorkbook.Path ' or any other valid path
Filename = Format(Date, "yymmdd ") & "MyFile's name"
Ext = "xlsm"
With ActiveWorkbook
.SaveAs Filepath & "\" & Filename & "." & Ext
.Close
End With
End Sub
How to close the workbook using the filename that I already set?
It depends
Is the workbook already saved once?
Is it a newly created workbook?
Also what is the format (xlsx/xlsm) you are going to use.
See this example for saving as Xlsx
Dim x As String
x = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
Dim Filepath As String
Filepath = ThisWorkbook.Path
Dim sFilename As String
sFilename = Filepath & "\" & x & ".xlsx"
Dim wb As Workbook
'~~> If already saved once
Set wb = Workbooks(x & ".xlsx")
'~~> If newly created and has the name `x`
Set wb = Workbooks(x)
wb.SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbook
wb.Close (False)
Note:
Filename2 = Filepath & "" & x & ".xlsm"
When using saving it as .xlsm you have to be very careful as you are going to use the original file name; basically trying to overwrite the same file.
I want to run through a specific sheet (from & to) save those ws as a new file in a folder, if the folder doesn't exist then create.
I'm able to do it to one sheet.
ActiveSheet.Next.Select
If Range("F3").Value = "" Then
Windows("Import OT.xlsm").Activate
Sheets("Cash").Select
Dim filename101 As String
Dim path101 As String
Application.DisplayAlerts = False
path101 = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
filename101 = Range("B1").Value & ".xlsx"
ActiveWorkbook.SaveAs path101 & Range("A2") & "\" & Range("A1") & " " & filename101,xlOpenXMLWorkbook
Application.DisplayAlerts = True
Else
Cells.Select
Range("F3").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Dim Path1 As String
Dim fpathname1 As String
Path1 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\"
fpathname1 = Path1 & Range("F3") & "\" & Range("F2") & " " & Range("B3") & ".xlsx"
path01 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & Range("F3")
Dim path001 As String
Dim Folder As String
Folder = Dir(path01, vbDirectory)
If Folder = vbNullString Then
VBA.FileSystem.MkDir (path01)
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
Else
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
End If
End If
End Sub
I want this as a loop is because I have a few tens of sheets. For it to work I think I need to write it specific time, but with loop I learned I don't need to do that.
Excel file sheet
https://onedrive.live.com/view.aspx?resid=AF6FF2618C09AC74!29027&ithint=file%2cxlsx&authkey=!AHcJjYCu8D0NTNY
According to your comment where you wrote the steps:
Read the comments
Try to run the code using F8 key and see where you need to change it.
As you're learning, please note to first write the steps in plain English Norsk and then develop your code.
See how I just followed your steps with readable code.
Code:
Public Sub GenerateCustomersFiles()
' 1) Active sheet (oppgjør 1-20)
Dim targetSheet As Worksheet
For Each targetSheet In ThisWorkbook.Sheets
' Check only sheets with string in name
If InStr(targetSheet.Name, "Oppgjør") > 0 Then
' 2) look if value in F3 is empty
If targetSheet.Range("F3").Value = vbNullString Then
' 3) if it is, do select "cash" sheet and save this file (its name and path are given above what it should be named)
Dim fileName As String
Dim filePath As String
Dim folderPath As String
folderPath = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
fileName = targetSheet.Range("B1").Value & ".xlsx"
filePath = folderPath & targetSheet.Range("A2") & "\" & targetSheet.Range("A1") & " " & fileName
ThisWorkbook.Worksheets("Cash").Select
ThisWorkbook.SaveAs filePath, xlOpenXMLWorkbook
Else
' 4) if it doesn't, do open selected sheet to a new workbook and save that in clients name folder (folder and path given above in code section)
folderPath = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & targetSheet.Range("F3")
fileName = targetSheet.Range("F2") & " " & targetSheet.Range("B3") & ".xlsx"
filePath = folderPath & "\" & fileName
' 5) check if clients folder exist or not for the file to be saved in.
' if folder doesnt exist,
' create new and save file there.
CreateFoldersInPath folderPath
' if folder exist just save the file there
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Add
targetSheet.Copy before:=targetWorkbook.Sheets(1)
targetWorkbook.SaveAs filePath, 51
targetWorkbook.Close
End If
End If
Next targetSheet
End Sub
' Credits: https://stackoverflow.com/a/31034201/1521579
Private Sub CreateFoldersInPath(ByVal targetFolderPath As String)
Dim strBuildPath As String
Dim varFolder As Variant
If Right(targetFolderPath, 1) = "\" Then targetFolderPath = Left(targetFolderPath, Len(targetFolderPath) - 1)
For Each varFolder In Split(targetFolderPath, "\")
If Len(strBuildPath) = 0 Then
strBuildPath = varFolder & "\"
Else
strBuildPath = strBuildPath & varFolder & "\"
End If
If Len(Dir(strBuildPath, vbDirectory)) = 0 Then MkDir strBuildPath
Next varFolder
'The full folder path has been created regardless of nested subdirectories
'Continue with your code here
End Sub
Let me know how it goes
I'd to create check if a file is exists using the shipNo and FilePath. If not, copy master.xls and rename the file according to shipNo. In all cases open the file afterwards.
Private Sub PDFButton_Click()
On Error Resume Next
Dim SourceFile As String, destFile As String, sourceExtension, shipNo As String
'Initialize variables
shipNo = Range("D4").Value
FilePath = "C:\Users\*\Documents\QueueRecord\"
SourceFile = "C:\Users\*\Documents\QueueRecord\Gen master.xls\"
If (destFile) = "" Then
Dim fso, createText As FileSystemObject
Set fso = New Scripting.FileSystemObject
fso.CopyFile SourceFile, FilePath & "SampleFileCopy.xls\"
Set createText = fso.CreateTextFile(FilePath, True, True)
createText.Write "success"
createText.Close
If fso.FileExists(FilePath & "SampleFileCopy.xls\") Then
MsgBox "Success"
End If
End If
ActiveWorkbook.FollowHyperlink ("C:\Users\*\Documents\QueueRecord\" + shipNo + ".xls\")
End Sub
In my tests SampleFileCopy.xls is never created, nor is the textFile created.
destFile will always be empty the way you have it written. I'm assuming you want the line to look like:
If dir(FilePath & shipNo & ".xls") = "" Then
Also, remove all the back slashes after the full file paths.
this:
"C:\Users\*\Documents\QueueRecord\Gen master.xls\"
should be this:
Environ("userprofile") & "\Documents\QueueRecord\Gen master.xls"
Also, as stated in the comments, remove the "on error resume next" so you know where the code is breaking.
Full code below, based on the assumption that destFile is supposed to be filepath and shipNo:
Private Sub PDFButton_Click()
Dim SourceFile As String, destFile As String, sourceExtension, shipNo As String
'Initialize variables
shipNo = Range("D4").Value
FilePath = Environ("userprofile") & "\Documents\QueueRecord\"
SourceFile = Environ("userprofile") & "\Documents\QueueRecord\Gen master.xls"
If Dir(FilePath & shipNo & ".xls", vbDirectory) = "" Then
Dim fso As FileSystemObject
Set fso = New Scripting.FileSystemObject
fso.CopyFile SourceFile, FilePath & "SampleFileCopy.xls"
'create text file
TextFile = FreeFile
Open FilePath & shipNo & ".txt" For Output As TextFile
Print #TextFile, "success";
Close TextFile
If fso.FileExists(FilePath & "SampleFileCopy.xls") Then
MsgBox "Success"
End If
End If
ActiveWorkbook.FollowHyperlink (Environ("userprofile") & "\Documents\QueueRecord\" & shipNo & ".xls")
End Sub
I have a small script allowing me to traverse through all xslx files in the current folder, and saving them all as xml worksheets.
That works fine, but I'd like to save them in a subfolder, and that's where things go wrong as I'm always saving the same file again. I'm not too familiar with the Dir syntax, so if someone could help me out a bit I would be really grateful.
This part works as expected :
Sub XLS2XML()
Application.DisplayAlerts = False
Dim folderPath As String
Dim Report As String
Dim ReportName As String
Dim XMLLocation As String
Dim XMLReport As String
Dim WB As Workbook
'set path to current location
folderPath = ThisWorkbook.Path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'loop through all xlsx files
Report = Dir(folderPath & "*.xlsx")
Do While Report <> ""
Set WB = Workbooks.Open(folderPath & Report)
'get the file name without path
ReportName = Split(Report, ".")(0)
XMLLocation = folderPath
XMLReport = XMLLocation & ReportName & ".xml"
'save the file as xml workbook
ActiveWorkbook.SaveAs filename:=XMLReport, _
FileFormat:=xlXMLSpreadsheet, ReadOnlyRecommended:=False, CreateBackup:=False
'close and next
WB.Close False
Report = Dir
Loop
MsgBox "All XML files have been created"
Application.DisplayAlerts = True
End Sub
and this one fails on me :
Sub XLS2XML()
Application.DisplayAlerts = False
Dim folderPath As String
Dim Report As String
Dim ReportName As String
Dim XMLLocation As String
Dim XMLReport As String
Dim WB As Workbook
'set path to current location
folderPath = ThisWorkbook.Path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'loop through all xlsx files
Report = Dir(folderPath & "*.xlsx")
Do While Report <> ""
Set WB = Workbooks.Open(folderPath & Report)
'get the file name without path and save it in xml folder
ReportName = Split(Report, ".")(0)
XMLLocation = folderPath & "xml"
XMLReport = XMLLocation & "\" & ReportName & ".xml"
'create xml folder if it doesn't exist yet
If Len(Dir(XMLLocation, vbDirectory)) = 0 Then
MkDir XMLLocation
End If
'save the file as xml workbook
ActiveWorkbook.SaveAs filename:=XMLReport, _
FileFormat:=xlXMLSpreadsheet, ReadOnlyRecommended:=False, CreateBackup:=False
'close and next
WB.Close False
Report = Dir
Loop
Any idea where my syntax goes wrong ? Also, is it possible to do the same thing in silent mode ? So without opening the workbooks ?
Thanks !
Your issue is that you are using a second Dir within your initial Dir loop to test and create the xml subdirectory.
You can - and should move this outside the loop - especially as it is a one-off test and shouldn't be looped to begin with. Something like this below
(You otherwise used Dir fine, as per my simple wildcard code example in Loop through files in a folder using VBA?)
Sub XLS2XML()
Application.DisplayAlerts = False
Dim folderPath As String
Dim Report As String
Dim ReportName As String
Dim XMLlocation As String
Dim XMLReport As String
Dim WB As Workbook
'set path to current location
folderPath = ThisWorkbook.Path
XMLlocation = folderPath & "xml"
If Len(Dir(XMLlocation, vbDirectory)) = 0 Then MkDir XMLlocation
If Right$(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'loop through all xlsx files
Report = Dir(folderPath & "*.xlsx")
Do While Len(Report) > 0
Set WB = Workbooks.Open(folderPath & Report)
'get the file name without path and save it in xml folder
ReportName = Split(Report, ".")(0)
XMLReport = XMLlocation & "\" & ReportName & ".xml"
'save the file as xml workbook
WB.SaveAs Filename:=XMLReport, _
FileFormat:=xlXMLSpreadsheet, ReadOnlyRecommended:=False, CreateBackup:=False
'close and next
WB.Close False
Report = Dir
Loop
End Sub