I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows. How can I delete complete empty rows before copying or exclude them from copying?
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
wsSource.Activate
wsSource.Range("A:F").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
With wsSource
.Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2")
.Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2")
.Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2")
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
With this command "wsSource.Range("A:F").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete" ended with the error code 800A0408 - invalid chars.
Related
I'm trying to import multiple Excelfiles with multiple sheets.
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
strFileName = "C:\SomeFile\File.xlsx"
Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set colWorksheets = objWorkbook.Worksheets
For Each objWorksheet in colWorksheets
Set objRange = objWorksheet.UsedRange
strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)
objAccess.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"Vulnerability", strFileName, True, strWorksheetName
Next
I have a problem with the range. The variable strWorksheetName = "BE900!A1:L1634".
I get a runtime-error '3011'. The "!" is replaced by "$" so the sheet isn't found.
Any ideas?
ALL of my code
Public Function ImportFiles()
Dim strFolder As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strFile As String
Dim strTable As String
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
Dim varPieces As Variant
With Application.FileDialog(3) ' msoFileDialogFolderPicker
.AllowMultiSelect = True
.Title = "Please select one or more files"
.Initialfilename = "*.xls*"
If .Show Then
strFullFileName = .SelectedItems(1)
Else
MsgBox "No folder specified!", vbCritical
Exit Function
End If
End With
strFile = Dir(strFolder)
Set db = CurrentDb()
strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
strTable = DetermineTable(strFile)
strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
"WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)
varPieces = Split(strFile, ".")
strExtension = varPieces(UBound(varPieces))
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
Set objexcel = CreateObject("Excel.Application")
Set objworkbook = objexcel.Workbooks.Open(strFullFileName)
Set colworksheets = objworkbook.Worksheets
For Each objWorksheet In colworksheets
Set objRange = objWorksheet.UsedRange
**strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)**
'strWorksheetName = objRange.Address(0, 0, external:=True)
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
tableName:=strTable, _
FileName:=strFile, _
HasFieldNames:=False, _
**Range:=CStr(strWorksheetName)**
Next
colworksheets.Close
colworksheets = Nothing
objworkbook.Close
objworkbook = Nothing
objexcel.Close
objexcel = Nothing
Set db = CurrentDb()
Set tdf = db.TableDefs(strTable)
'Add the field to the table.
If FieldExistsInTable(strTable, "FileName") = True Then
'Do nothing
Else
tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)
'tdf.fields.append tdf.createField("SheetName", dbText, 255)
End If
'Supply the parameter value for the UPDATE and execute it ...
qdf.Parameters("pFileName").Value = strFile
qdf.Execute 'dbFailOnError
'Move to the next file
strFile = Dir
Loop
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
'rstTable.Close
Set rstTable = Nothing
End Function
Macro does not have an error, works well in my PC.
You can try a PC restart.
I this does not help, you may define strWorksheetName2, replace $ in strWorksheetName with !. Then give it to access object.
Rebuilded the code from scratch in a new db, now it works.
Thanks for the assistance.
I'm working on a macro in my Excel File.
I want to export six worksheets as new backup files.
There are several sheets that I also don't want to export.
When I run the code as it is now there is one/two sheets that are being exported while the remaining four aren't exported.
The two exported sheets are then also being closed after they are saved as a new file.
I hope someone is able to help me and give me advice and feedback.
Thanks in advance.
My code is:
'''
Sub SplitWorkbook2()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "mm-dd hh-mm")
FolderName = "I:\Export\Backup\TEMPS\2021\Urenlijsten\" & " Werkbriefjes week " & Range("C4") & " " & DateString
MkDir FolderName
Application.DisplayAlerts = False
On Error GoTo NErro
DoNotInclude = "Actions" & "Adressbook" & "Import" & "Hours_Database"
FileExtStr = ".xls"
For Each xWs In xWb.Sheets
If InStr(DoNotInclude, xWs.Name) = 0 Then
xWs.Copy
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
With xNWb
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
xFile = FolderName & "\" & Range("C6") & FileExtStr
xNWb.SaveAs xFile, FileFormat:=xlOpenXMLWorkbook
End With
End If
Next xWs
NErro: xWb.Activate
xWb.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "You can find the files in " & FolderName
End Sub
Export Worksheets
Not tested.
Option Explicit
Sub SplitWorkbook2()
Dim wb As Workbook
Dim ws As Worksheet
Dim DoNotInclude As Variant
Dim FileFormatNum As Long
Dim FileExtStr As String
Dim FolderName As String
FolderName = "I:\Export\Backup\TEMPS\2021\Urenlijsten\" & " Werkbriefjes week " & Range("C4") & " " & DateString
FileExtStr = ".xlsx" ' ??? not '.xls'
DateString = Format(Now, "mm-dd hh-mm")
DoNotInclude = Array("Actions" & "Adressbook" & "Import" & "Hours_Database")
On Error Resume Next
MkDir FolderName
On Error GoTo 0
Set wb = ThisWorkbook
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, DoNotInclude, 0)) Then
ws.Copy
With ActiveWorkbook.Worksheets(1)
.UsedRange.Value = .UsedRange.Value
xFile = FolderName & "\" & .Range("C6") & FileExtStr
Application.DisplayAlerts = False
.Parent.SaveAs xFile, FileFormat:=xlOpenXMLWorkbook
.Parent.Close
Application.DisplayAlerts = True
End With
End If
Next ws
Application.ScreenUpdating = True
MsgBox "You can find the files in " & FolderName
'wb.FollowHyperlink FolderName ' open in Windows File Explorer
End Sub
I have code for listing folders, sub folders and filenames. I have to choose a folder by clicking the code.
How it is possible to define path? I have tried to uncomment MyPath but it didn't work.
My path: "\infra\Services\turb"
Sub ListAllFilesInAllFolders()
Dim MyPath As String, MyFolderName As String, MyFileName As String
Dim i As Integer, F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
Dim MySheet As Worksheet
On Error Resume Next
'************************
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing
'************************
'List all folders
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i = i + 1
Loop
'List all files
For Each Key In AllFolders.keys
MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next
'************************
'List all files in Files sheet
For Each MySheet In ThisWorkbook.Worksheets
If MySheet.Name = "Files" Then
Sheets("Files").Cells.Delete
F = True
Exit For
Else
F = False
End If
Next
If Not F Then Sheets.Add.Name = "Files"
'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
---------------- EDIT ---------------------
Same path in another code that is working. This code is doing quite the same but I don't like the output of listing folders.
Option Explicit
Private iColumn As Integer
Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True)
Application.ScreenUpdating = False
Cells.Delete
Range("A1").Select
iColumn = 1
' add headers
With Range("A1")
.Formula = "Folder contents: " & strPath
.Font.Bold = True
.Font.Size = 12
End With
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
ListFolders strPath, bFolders
Application.ScreenUpdating = True
End Sub
ListFolders:
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
' example: ListFolders "C:\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
Dim strfile As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'line added by dr for repeated "Permission Denied" errors
On Error Resume Next
iColumn = iColumn + 1
' display folder properties
ActiveCell.Offset(1).Select
With Cells(ActiveCell.Row, iColumn)
.Formula = SourceFolder.Name
.Font.ColorIndex = 11
.Font.Bold = True
.Select
End With
strfile = Dir(SourceFolder.Path & "\*.*")
If strfile <> vbNullString Then
ActiveCell.Offset(0, 1).Select
Do While strfile <> vbNullString
ActiveCell.Offset(1).Select
ActiveCell.Value = strfile
strfile = Dir
Loop
ActiveCell.Offset(0, -1).Select
End If
Cells(r, 0).Formula = SourceFolder.Name
Cells(r, 3).Formula = SourceFolder.Size
Cells(r, 4).Formula = SourceFolder.SubFolders.Count
Cells(r, 5).Formula = SourceFolder.Files.Count
Cells(r, 6).Formula = SourceFolder.ShortName
Cells(r, 7).Formula = SourceFolder.ShortPath
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
iColumn = iColumn - 1
Next SubFolder
Set SubFolder = Nothing
End If
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Create new worksheet and list sub folders there:
Sub ListAllFilesTurb()
Dim WS As Worksheet
Set WS = Sheets.Add
Sheets.Add.Name = "Turb"
TestListFolders "\\infra\Services\turb"
End Sub
Get rid of the objFolder and objShell (and any dependent conditional code, etc.). Then you should be able to hardcode MyPath. As presently written, this code is using the objShell to browse.
Get rid of this:
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing
Replace with this:
' Define hard-coded folder:
MyPath = "\\infra\Services\turb" '# Modify as needed
NOTE: It is important that the MyPath end with a backslash character, while you can hardcode that on the same line, e.g.:
MyPath = "\\infra\Services\turb\"
It may be best to add a check for it (similar to the original code) just in case you forget, so:
MyPath = "\\infra\Services\turb"
'### Ensure the path ends with a separator:
MyPath = MyPath & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator)
I have implemented the below script but could not save the same as UTF-8 format.
How to save the converted CSV from Excel in UTF-8 CSV format using VBScript?
Dim strExcelFileName
Dim strCSVFileName
strExcelFileName = "C:\Users\test.xlsx"
Set fso = CreateObject("Scripting.FileSystemObject")
strScript = WScript.ScriptFullName
strScriptPath = fso.GetAbsolutePathName(strScript & "\..")
LPosition = InStrRev(strExcelFileName, "\")
If LPosition = 0 Then
strExcelFileName = strScriptPath & "\" & strExcelFileName
strScriptPath = strScriptPath & "\"
Else
strScriptPath = Mid(strExcelFileName, 1, LPosition)
End If
Set objXL = CreateObject("Excel.Application")
Set objWorkBook = objXL.Workbooks.Open(strExcelFileName)
objXL.DisplayAlerts = False
For Each sheet In objWorkBook.Sheets
If objXL.Application.WorksheetFunction.CountA(sheet.Cells) <> 0 Then
sheet.SaveAs strScriptPath & sheet.Name & cell & ".csv", 6 'CSV
End If
Next
objWorkBook.Close
objXL.Quit
Set objXL = Nothing
Set objWorkBook = Nothing
Set fso = Nothing
Try 62 instead of 6 in the save line like this:
sheet.SaveAs strScriptPath & sheet.Name & cell & ".csv", 62
I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows and not needed blue rows. How can I delete this complete empty rows before copying or exclude them from copying?
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
With wsSource
.Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2")
.Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2")
.Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2")
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
With wsTarget
Fcol.Copy .Range("A2")
Acol.Copy .Range("B2")
Ecol.Copy .Range("C2")
End With
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim ix
with wsTarget
for ix = rowcount + 1 to 2 step -1
if Len(.cells(ix,1))=0 and len(.cells(ix,2))=0 and len(.cells(ix,3))=0 then
.rows(ix).delete
'//Check for blue rows assuming all cells in the row have the same color
elseif .cells(ix, 1).Interior.Color = iBlueColor then
.rows(ix).delete
end if
next
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Function Max(v1, v2, v3)
select case true
case v1 => v2 and v1 => v3
Max = v1
case v2 => v3
Max = v2
case else
Max = v3
end select
end function
This is an alternative approach to my original in an attempt to improve performance. In this case, instead of using Excel to create the csv file, the VBScript code writes the csv file directly using a text file created by FileSystemObject. I have tested this with a larger set of source data and it seems to be quite a bit quicker than the original - about 40 seconds for 1500 rows. There is still an overhead of opening the Excel application (about 5-10 seconds) but there's not much you can do about that. If performance is important to you there may be other improvements that you could do.
If you have numeric values in the spreadsheet, you may need to do some formatting to convert to string values suitable for csv output, because Excel tends to use exponential notation for numbers converted to text, which is not always what you want. I have also used quotation marks and comma separators but you could use different formatting conventions for your CSV output. You may want to change the use of WriteLine because this appends a CrLf after the last line, which might be interpreted downstream as a blank row.
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
msgbox "starting"
call xlsToCsv()
msgbox "finished"
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
Dim oOutputFile
myFile = "source_file.xlsx"
SaveName = "test2.csv"
With CreateObject("Scripting.FilesystemObject")
'// Check that the input file exists
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
'// Create a text file to be the output csv file
'// Overwrite v v False=ASCII format use True for Unicode format
set oOutputFile = .CreateTextFile( WorkingDir & SaveName, True, False)
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
oOutputFile.WriteLine """ID"",""NAME"",""DESC"""
'// Get the three column ranges, starting at cells in row 7
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
'// Get the number of rows in each column
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
'// Rowcount is the max row of the three
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim AVal, FVal, EVal
dim ix
for ix = 1 to rowcount
'// Note - row 1 of each column is actually row 7 in the workbook
AVal = REPLACE(ACol.Cells(ix, 1), """", """""")
EVal = REPLACE(ECol.Cells(ix, 1), """", """""")
FVal = REPLACE(FCol.Cells(ix, 1), """", """""")
'// Check for an empty row
if Len(AVal)=0 and len(EVal)=0 and len(FVal)=0 then
'// skip this row
'// Check for a blue row
elseif ACol.cells(ix,1).Interior.Color = iBlueColor then
'// skip this row
else
'// Write the line to the csv file
oOutputFile.WriteLine """" & FVal & """,""" & AVal & """,""" & EVal & """"
end if
next
'// Close the output file
oOutputFile.Close
'// Close the workbook
objWorkbook.Close True
objExcel.Quit
'// Clean up
Set oOutputFile = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
Function Max(v1, v2, v3)
select case true
case v1 >= v2 and v1 >= v3
Max = v1
case v2 >= v3
Max = v2
case else
Max = v3
end select
end function