FileSystemObject

Today, let’s try the FileSystemObject.

What is FileSystemObject?
The FileSystemObject, or FSO, is an often used component to access the file system. For example, you can create files, read the contents of files, determine whether or not a folder or file exists, iterate through the contents of a folder or directory, or any other number of file system-related tasks.

FileSystemObject can be found in Scrrun.dll. In addition to FileSystemOject, Scrrun.dll includes four other objects available for File I/O and other tasks. These objects include the File object, the TextStreamObject object, the Folder object, and the Drive object. We will concentrate on FileSystemObject.

Public Sub CreateFolder()
    'Create a folder using FileSystemObject
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim FolderPath As String, FolderNameToCreate As String, FullPath As String

    'Get the folder path and folder name to create
    FolderPath = Sheets(“Create”).Range(“B1”).Value
    FolderNameToCreate = Sheets(“Create”).Range(“B2”).Value

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    'Check if “\” (backslash) is available at the end of the folder path and add if it’s not there
    If Right(FolderPath, 1) <> “\” Then FolderPath = FolderPath & “\”

    If Not objFileSystemObject.FolderExists(FolderPath) Then
        'If the folder path does not exist
        MsgBox “The folder, ” & FolderPath & ” does not exist.”, _
            vbOKOnly, “Create Folder Using FSO”
        Exit Sub
    End If

    FullPath = FolderPath & FolderNameToCreate

    If Not objFileSystemObject.FolderExists(FullPath) Then
        'If the folder to create does not exist, create the folder
        Call objFileSystemObject.CreateFolder(FullPath)
    Else
        'If the folder to create exists
        MsgBox “The folder, ” & FolderNameToCreate & ” already exists!”, _
            vbOKOnly, “Create Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Public Sub CopyFolder()
    'Copy a folder using FileSystemObject
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim SourceFilePath As String, DestinationFilePath As String

    'Get source folder and target folder names
    SourceFilePath = Sheets(“Copy”).Range(“B1”).Value
    DestinationFilePath = Sheets(“Copy”).Range(“B2”).Value

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(SourceFilePath, 1) = “\” Then _
        SourceFilePath = Left(SourceFilePath, (Len(SourceFilePath) – 1))

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(DestinationFilePath, 1) = “\” Then _
        DestinationFilePath = Left(DestinationFilePath, (Len(DestinationFilePath) – 1))

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    If Not objFileSystemObject.FolderExists(SourceFilePath) Then
        'If source folder does not exist
        MsgBox “The folder, ” & SourceFilePath & ” does not exist.”, _
            vbOKOnly, “Copy Folder Using FSO”

        Exit Sub
    End If

    If Not objFileSystemObject.FolderExists(DestinationFilePath) Then
        'If destination folder does not exist
        objFileSystemObject.CopyFolder SourceFilePath, DestinationFilePath
    Else
        'If destination folder exists
        MsgBox “The folder, ” & DestinationFilePath & ” already exists!”, _
            vbOKOnly, “Copy Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Public Sub MoveFolder()
    'Move a folder using FileSystemObject (moving and renaimg a folder)
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim SourceFilePath As String, DestinationFilePath As String

    'Get source folder and target folder names
    SourceFilePath = Sheets(“Move”).Range(“B1”).Value
    DestinationFilePath = Sheets(“Move”).Range(“B2”).Value

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(SourceFilePath, 1) = “\” Then _
        SourceFilePath = Left(SourceFilePath, (Len(SourceFilePath) – 1))

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(DestinationFilePath, 1) = “\” Then _
        DestinationFilePath = Left(DestinationFilePath, (Len(DestinationFilePath) – 1))

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    If Not objFileSystemObject.FolderExists(SourceFilePath) Then
        'If source folder does not exist
        MsgBox “The folder, ” & SourceFilePath & ” does not exist.”, _
            vbOKOnly, “Move Folder Using FSO”
        Exit Sub
    End If

    If Not objFileSystemObject.FolderExists(DestinationFilePath) Then
        'If destination folder does not exist, move the folder
        objFileSystemObject.MoveFolder SourceFilePath, DestinationFilePath
    Else
        'If destination folder exists
        MsgBox “The folder, ” & DestinationFilePath & ” already exists!”, _
            vbOKOnly, “Move Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Public Sub DeleteFolder()
    'Delete a folder using FileSystemObject
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim RemoveFolderPath As String

    'Get folder path to Delete
    RemoveFolderPath = Sheets(“Delete”).Range(“B1”).Value

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(RemoveFolderPath, 1) = “\” Then _
        RemoveFolderPath = Left(RemoveFolderPath, (Len(RemoveFolderPath) – 1))

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    If objFileSystemObject.FolderExists(RemoveFolderPath) Then
        'If the folder exists, delete the folder
        objFileSystemObject.DeleteFolder RemoveFolderPath, True
    Else
        'If folder does not exist
        MsgBox “The folder, ” & RemoveFolderPath & ” does not exist.”, _
            vbOKOnly, “Move Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub
Advertisements

Sorting Worksheets In Ascending Or Descending Order

Today, I would like to show a code which I created to sort the worksheets in ascending or descending order in the current workbook. I have opted bubble sort to sort the names.

What did I do?

First, I counted the number of worksheets available in the current workbook. Then created an array and saved the worksheets’ names in the array, sorted the names in ascending or descending order (two codes – based on your requirement, you can choose any one) and moved the worksheets according to the sorted order. In the end, show/select the first worksheet.

Here goes the code:

Sub SortWorksheetNamesAscending()
    Dim NoOfSheets As Long, Counter As Long
    Dim Counter1 As Long, Counter2 As Long
    Dim TemporaryVariable As String
    Dim WkShtsNames() As String

    'Count the number of sheets in the workbook
    NoOfSheets = ActiveWorkbook.Worksheets.Count

    'Redefine and assign the names of the worksheets in WkShtsNames array
    ReDim WkShtsNames(1 To NoOfSheets)
    For Counter = 1 To NoOfSheets
        WkShtsNames(Counter) = ActiveWorkbook.Worksheets(Counter).Name
    Next Counter

    'Sort the worksheets' names in ascending order
    For Counter1 = LBound(WkShtsNames) To UBound(WkShtsNames)
        For Counter2 = LBound(WkShtsNames) To UBound(WkShtsNames)
            If WkShtsNames(Counter1) < WkShtsNames(Counter2) Then
                TemporaryVariable = WkShtsNames(Counter1)
                WkShtsNames(Counter1) = WkShtsNames(Counter2)
                WkShtsNames(Counter2) = TemporaryVariable
            End If
        Next Counter2
    Next Counter1

    'Move the worksheets according to the sorted order
    For Counter = 1 To NoOfSheets
        If Counter = 1 Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets(1)
            End If
        ElseIf Counter = NoOfSheets Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets.Count
            End If
        Else
            ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets(Counter – 1).Name)
        End If
    Next Counter

    'Select the first worksheet
    ActiveWorkbook.Worksheets(1).Select
End Sub

Sub SortWorksheetNamesDescending()
    Dim NoOfSheets As Long, Counter As Long
    Dim Counter1 As Long, Counter2 As Long
    Dim TemporaryVariable As String
    Dim WkShtsNames() As String

    ‘Count the number of sheets in the workbook
    NoOfSheets = ActiveWorkbook.Worksheets.Count

    ‘Redefine and assign the names of the worksheets in WkShtsNames array
    ReDim WkShtsNames(1 To NoOfSheets)
    For Counter = 1 To NoOfSheets
        WkShtsNames(Counter) = ActiveWorkbook.Worksheets(Counter).Name
    Next Counter

    ‘Sort the worksheets’ names in descending order
    For Counter1 = LBound(WkShtsNames) To UBound(WkShtsNames)
        For Counter2 = LBound(WkShtsNames) To UBound(WkShtsNames)
            If WkShtsNames(Counter1) > WkShtsNames(Counter2) Then
                TemporaryVariable = WkShtsNames(Counter1)
                WkShtsNames(Counter1) = WkShtsNames(Counter2)
                WkShtsNames(Counter2) = TemporaryVariable
            End If
        Next Counter2
    Next Counter1

    ‘Move the worksheets according to the sorted order
    For Counter = 1 To NoOfSheets
        If Counter = 1 Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets(1)
            End If
        ElseIf Counter = NoOfSheets Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets.Count
            End If
        Else
            ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets(Counter – 1).Name)
        End If
    Next Counter

    ‘Select the first worksheet
    ActiveWorkbook.Worksheets(1).Select
End Sub

Zip Files Through VBA Using Windows Built-in Zip Utility

Before I could start talking about this, I would like to sincerely thank Ron de Bruin and Vishesh for their efforts to create codes on native windows zip utility and use them. Seriously, without your support (through your website), I would not have created these codes.

What is Windows Built-in Zip Utility Application?

Starting Windows XP (I believe), has basic built-in zip capability so that you can compress files by using the Compressed (zipped) Folder feature. Folders compressed by using this feature are identified by a zippered folder icon. Compressing files, folders, and programs decreases their size and reduces the space they use on your drives or removable storage devices.

In order to create or modify a zip file, you would use 2 objects, namely, the Shell object and FileSystemObject object. The Windows Shell namespace is an organized tree-structured hierarchical representation that Windows Explorer facilitates to graphically present file system contents and other objects to the end user. Conceptually, the Shell namespace may be regarded as a larger and more inclusive version of the file system. The FileSystemObject object is used to access the file system on a server or a local system. This object can manipulate files, folders, and directory paths. It is also possible to retrieve file system information with this object.

Ron’s code uses Application.GetOpenFilename to get the names of the file(s)/zip file.

Vishesh’s code explains to use a double quotes (") for each individual file path(s).

I just want to avoid using these and want the input for the user to be simple. The user simply enters the information in the cells and the code just picks them up and gives the end result. No selection of files or giving the path(s) in double quotes. Just type the source file(s) path(s)/files to extract with a comma (,) in between (not required at the end).

For example:

Files to zip: C:\Test\File1.txt,C:\Test\File2.txt

Notice that there is no gap between the comma and the next file path.

Files to extract: File1.txt,File2.txt

Notice that there is no gap between the comma and the next file path.

Please add some additional codes for checking if the folder/file(s)/zip file (already) exists.

I know that the code can be tweaked some more for performance reason. So, please feel free to make changes. Also, let me know so that I can also keep a note of them.

Again, my sincere thanks to Ron and Vishesh.

Here go the codes:

' *** Zip Files *** 
Sub Zip_Files() 
    'Create a zip file and add file(s) into it
    Dim src_files As String 
    Dim dest_file As String 
    Dim src_file_path As String 
    Dim src_file_name As String 
    
    Dim arr_src_files() As String 
    Dim var_dest_file 
    Dim arr_files() 
    
    Dim lngCounter As Long, lngFileCounter As Long 
    
    Dim oFSO As Object 
    Dim oFolder As Object 
    Dim oFile As Object 
    
    Dim oSA As Object 
    
    'Get source and destination files 
    src_files = Sheets("Sheet1").Range("B1").Value 
    dest_file = Sheets("Sheet1").Range("B2").Value 
    
    'Create FileSystemObject object 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    
    'Add .zip at the end of destination file if .zip is not there 
    If Right(dest_file, 4) <> ".zip" Then dest_file = dest_file & ".zip" 
    var_dest_file = dest_file 
    
    'Put all the source files into an array 
    arr_src_files = Split(src_files, ",") 
    
    'Define the size of the array arr_files 
    ReDim arr_files(((UBound(arr_src_files) – LBound(arr_src_files)) + 1)) 
    
    'Get all the files as objects 
    For lngCounter = LBound(arr_src_files) To UBound(arr_src_files) 
        src_file_path = Left(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "\", , vbTextCompare)) 
        src_file_name = Mid(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "\") + 1) 
        
        Set oFolder = oFSO.GetFolder(src_file_path) 
        For Each oFile In oFolder.Files 
            If InStr(oFile, src_file_name) Then 
                arr_files(lngCounter) = oFile 
                Exit For 
            End If 
        Next oFile 
        
        If lngCounter = UBound(arr_src_files) Then Exit For 
    Next lngCounter 
    
    'If the zip file already exists, delete the file 
    If Len(Dir(var_dest_file)) > 0 Then Kill var_dest_file 
    
    'Create an empty zip file 
    Open var_dest_file For Output As #1 
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 
    Close #1 
    
    'Create Shell object 
    Set oSA = CreateObject("Shell.Application") 
    
    'Add files into the zip file 
    lngFileCounter = 0 
    For lngCounter = LBound(arr_files) To (UBound(arr_files) – 1) 
        'Copy file to zip folder/file created above 
        lngFileCounter = lngFileCounter + 1 
        oSA.Namespace(var_dest_file).CopyHere arr_files(lngCounter) 
        
        'Wait until compressing is complete 
        On Error Resume Next 
        Do Until oSA.Namespace(var_dest_file).Items.Count = lngFileCounter 
            Application.Wait (Now + TimeValue("0:00:01")) 
        Loop 
        On Error GoTo 0 
    Next lngCounter 
    
    Set oSA = Nothing 
    Set oFile = Nothing 
    Set oFolder = Nothing 
    Set oFSO = Nothing 
End Sub

Sub Add_Files_To_Zip_File() 
    'Add file(s) into an existing zip file 
    Dim src_files As String 
    Dim dest_file As String 
    Dim src_file_path As String 
    Dim src_file_name As String 
    
    Dim arr_src_files() As String 
    Dim var_dest_file 
    Dim arr_files() 
    
    Dim lngCounter As Long, lngFileCounter As Long 
    
    Dim oFSO As Object 
    Dim oFolder As Object 
    Dim oFile As Object 
    
    Dim oSA As Object 
    
    'Get source and destination files 
    src_files = Sheets("Sheet2").Range("B1").Value 
    dest_file = Sheets("Sheet2").Range("B2").Value 
    
    'Create FileSystemObject object 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    
    'Add .zip at the end of destination file if .zip is not there 
    If Right(dest_file, 4) <> ".zip" Then dest_file = dest_file & ".zip" 
    var_dest_file = dest_file 
    
    'Put all the source files into an array 
    arr_src_files = Split(src_files, ",") 
    
    'Define the size of the array arr_files 
    ReDim arr_files(((UBound(arr_src_files) – LBound(arr_src_files)) + 1)) 
    
    'Get all the files as objects 
    For lngCounter = LBound(arr_src_files) To UBound(arr_src_files) 
        src_file_path = Left(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "\", , vbTextCompare)) 
        src_file_name = Mid(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "\") + 1) 
        
        Set oFolder = oFSO.GetFolder(src_file_path) 
        For Each oFile In oFolder.Files 
            If InStr(oFile, src_file_name) Then 
                arr_files(lngCounter) = oFile 
                Exit For 
            End If 
        Next oFile 
        
        If lngCounter = UBound(arr_src_files) Then Exit For 
    Next lngCounter 
    
    'Create a Shell object 
    Set oSA = CreateObject("Shell.Application") 
    
    'Add files into the zip file 
    lngFileCounter = 0 
    For lngCounter = LBound(arr_files) To (UBound(arr_files) – 1) 
        'Copy file to zip folder/file 
        oSA.Namespace(var_dest_file).CopyHere arr_files(lngCounter) 
        
        'Wait until compressing is complete 
        On Error Resume Next 
        lngFileCounter = (oSA.Namespace(var_dest_file).Items.Count + 1) 
        Do Until oSA.Namespace(var_dest_file).Items.Count = lngFileCounter 
            Application.Wait (Now + TimeValue("0:00:01")) 
        Loop 
        On Error GoTo 0 
    Next lngCounter 
    
    Set oSA = Nothing 
    Set oFile = Nothing 
    Set oFolder = Nothing 
    Set oFSO = Nothing 
End Sub

' *** Unzip Files *** 
Sub Unzip_All_Files() 
    'Extract all files from a zip file 
    Dim src_zip_file As String 
    Dim dest_folder As String 
    Dim src_file_path As String 
    Dim src_file_name As String 
    
    Dim arr_src_file() As String 
    Dim var_dest_folder 
    Dim arr_files() 
    
    Dim lngCounter As Long, lngFileCounter As Long 
    
    Dim oFSO As Object 
    Dim oFolder As Object 
    Dim oFile As Object 
    
    Dim oSA As Object 
    
    'Get source zip file and destination folder 
    src_zip_file = Sheets("Sheet3").Range("B1").Value 
    dest_folder = Sheets("Sheet3").Range("B2").Value 
    
    'Create FileSystemObject object 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    
    var_dest_folder = dest_folder 
    
    arr_src_file = Split(src_zip_file, ",") 
    
    'Define the size of the array arr_files 
    ReDim arr_files(((UBound(arr_src_file) – LBound(arr_src_file)) + 1)) 
    
    'Get all the files as objects 
    For lngCounter = LBound(arr_src_file) To UBound(arr_src_file) 
        src_file_path = Left(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "\", , vbTextCompare)) 
        src_file_name = Mid(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "\") + 1) 
        
        Set oFolder = oFSO.GetFolder(src_file_path) 
        For Each oFile In oFolder.Files 
            If InStr(oFile, src_file_name) Then 
                arr_files(lngCounter) = oFile 
                Exit For 
            End If 
        Next oFile 
        
        If lngCounter = UBound(arr_src_file) Then Exit For 
    Next lngCounter 
    
    'Create a Shell object 
    Set oSA = CreateObject("Shell.Application") 
    
    'Extract all files into the destination folder 
    For lngCounter = LBound(arr_files) To (UBound(arr_files) – 1) 
        oSA.Namespace(var_dest_folder).CopyHere oSA.Namespace(arr_files(lngCounter)).Items 
    Next lngCounter 
    
    Set oSA = Nothing 
    Set oFile = Nothing 
    Set oFolder = Nothing 
    Set oFSO = Nothing 
End Sub

Sub Unzip_One_File() 
    'Extract one file from a zip file 
    Dim src_zip_file As String 
    Dim dest_folder As String 
    Dim src_file_path As String 
    Dim src_zip_file_name As String 
    Dim src_file_name As String 
    
    Dim arr_src_file() As String 
    Dim var_dest_folder 
    Dim src_file 
    Dim file_name_in_zip 
    Dim arr_files() 
    
    Dim lngCounter As Long, lngCounter1 As Long, lngCounter2 As Long, lngFileCounter As Long 
    
    Dim oFSO As Object 
    Dim oFolder As Object 
    Dim oFile As Object 
    
    Dim oSA As Object 
    
    'Get source zip file, file name to extract from the zip file, and destination folder 
    src_zip_file = Sheets("Sheet4").Range("B1").Value 
    src_file_name = Sheets("Sheet4").Range("B2").Value 
    dest_folder = Sheets("Sheet4").Range("B3").Value 
    
    'Create FileSystemObject object 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    
    var_dest_folder = dest_folder 
    
    arr_src_file = Split(src_zip_file, ",") 
    
    'Define the size of the array arr_files 
    ReDim arr_files(((UBound(arr_src_file) – LBound(arr_src_file)) + 1)) 
    
    'Get all the files as objects 
    For lngCounter = LBound(arr_src_file) To UBound(arr_src_file) 
        src_file_path = Left(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "\", , vbTextCompare)) 
        src_zip_file_name = Mid(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "\") + 1) 
        
        Set oFolder = oFSO.GetFolder(src_file_path) 
        For Each oFile In oFolder.Files 
            If InStr(oFile, src_zip_file_name) Then 
                arr_files(lngCounter) = oFile 
                Exit For 
            End If 
        Next oFile 
        
        If lngCounter = UBound(arr_src_file) Then Exit For 
    Next lngCounter 
    
    Set oFile = Nothing 
    
    'Create a Shell object 
    Set oSA = CreateObject("Shell.Application") 
    
    'Extract the file into the destination folder 
    For lngCounter1 = LBound(arr_files) To (UBound(arr_files) – 1) 
        For Each file_name_in_zip In oSA.Namespace(arr_files(lngCounter1)).Items 
            If LCase(Mid(file_name_in_zip.Path, InStrRev(file_name_in_zip.Path, "\") + 1)) Like LCase(src_file_name) Then 
                Set oFile = file_name_in_zip 
                
                If InStr(oFile.Path, src_file_name) Then 
                    oSA.Namespace(var_dest_folder).CopyHere oSA.Namespace(arr_files(lngCounter1)).Items.Item(CStr(src_file_name)) 
                    Exit For 
                End If 
            End If 
        Next file_name_in_zip 
    Next lngCounter1 
    
    Set oSA = Nothing 
    Set oFile = Nothing 
    Set oFolder = Nothing 
    Set oFSO = Nothing 
End Sub

Sub Unzip_Multiple_Files() 
    'Extract multiple files from a zip file 
    Dim src_zip_file As String 
    Dim dest_folder As String 
    Dim src_file_path As String 
    Dim src_zip_file_name As String 
    Dim src_file_names As String 
    
    Dim arr_src_file() As String 
    Dim arr_src_files() As String 
    Dim var_dest_folder 
    Dim src_file 
    Dim file_name_in_zip 
    Dim arr_files() 
    
    Dim lngCounter As Long, lngCounter1 As Long, lngCounter2 As Long, lngFileCounter As Long 
    
    Dim oFSO As Object 
    Dim oFolder As Object 
    Dim oFile As Object 
    
    Dim oSA As Object 
    
    'Get source zip file, file names to extract from the zip file, and destination folder 
    src_zip_file = Sheets("Sheet5").Range("B1").Value 
    src_file_names = Sheets("Sheet5").Range("B2").Value 
    dest_folder = Sheets("Sheet5").Range("B3").Value 
    
    'Create FileSystemObject object 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    
    var_dest_folder = dest_folder 
    
    arr_src_file = Split(src_zip_file, ",") 
    arr_src_files = Split(src_file_names, ",") 
    
    'Define the size of the array arr_files 
    ReDim arr_files(((UBound(arr_src_file) – LBound(arr_src_file)) + 1)) 
    
    'Get all the files as objects 
    For lngCounter = LBound(arr_src_file) To UBound(arr_src_file) 
        src_file_path = Left(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "\", , vbTextCompare)) 
        src_zip_file_name = Mid(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "\") + 1) 
        
        Set oFolder = oFSO.GetFolder(src_file_path) 
        For Each oFile In oFolder.Files 
            If InStr(oFile, src_zip_file_name) Then 
                arr_files(lngCounter) = oFile 
                Exit For 
            End If 
        Next oFile 
        
        If lngCounter = UBound(arr_src_file) Then Exit For 
    Next lngCounter 
    
    Set oFile = Nothing 
    
    'Create a Shell object 
    Set oSA = CreateObject("Shell.Application") 
    
    'Extract the files into the destination folder 
    For lngCounter1 = LBound(arr_files) To (UBound(arr_files) – 1) 
        For Each file_name_in_zip In oSA.Namespace(arr_files(lngCounter1)).Items 
            For lngCounter2 = LBound(arr_src_files) To UBound(arr_src_files) 
                If LCase(Mid(file_name_in_zip.Path, InStrRev(file_name_in_zip.Path, "\") + 1)) Like _ 
                    LCase(arr_src_files(lngCounter2)) Then 
                    Set oFile = file_name_in_zip 
                    
                    If InStr(oFile.Path, arr_src_files(lngCounter2)) Then 
                        oSA.Namespace(var_dest_folder).CopyHere _ 
                            oSA.Namespace(arr_files(lngCounter1)).Items.Item(CStr(arr_src_files(lngCounter2))) 
                        Exit For 
                    End If 
                End If 
            Next lngCounter2 
        Next file_name_in_zip 
    Next lngCounter1 
    
    Set oSA = Nothing 
    Set oFile = Nothing 
    Set oFolder = Nothing 
    Set oFSO = Nothing 
End Sub

Disclaimer

The codes in my site are (not entirely) written by me.
These codes are copied from different websites.
I do not take any credit for the codes that I copy from other websites.
At the same time, I would like to thank the people who wrote, tested and approved the codes in the websites.

I modify and use the codes according to my requirement.