creating Zip files from the list of files in Excel file

[nihad]

Good Evening All,

I have some files in and i want to group in a ZIP file, for that I have a list of files starting with first 3 common letters in Column A and want to group in Zip file in Column B. Is it possible through excel macro ???... if somebody help me out, i would be greatly appreciated...

Example

ColumnA	COlumn B
aaa_myfile1.pdf	myfile1.zip
aaa_myfile2.pdf	myfile1.zip
aaa_myfile3.pdf	myfile1.zip
bbb_myfile4.pdf	myfile2.zip
bbb_myfile5.pdf	myfile2.zip
bbb_myfile6.pdf	myfile2.zip
ccc_myfile7.pdf	myfile3.zip
ccc_myfile8.pdf	myfile3.zip
ccc_myfile9.pdf	myfile3.zip

 

[John_w]

Try this macro. You haven't said where the files in column A are located and where the files in column B should be created, so you need to edit the code below to change the PDFsFolder and ZipsFolder strings to the respective folder paths of those files.

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

'Constants from https://www.pinvoke.net/default.aspx/Constants.ShellAPI
'Descriptions from https://docs.microsoft.com/en-us/windows/desktop/shell/folder-copyhere
'Flags which aren't described on the latter page are commented out.

'Private Const FOF_MULTIDESTFILES = &H1
'Private Const FOF_CONFIRMMOUSE = &H2

Private Const FOF_SILENT = &H4                   'Do not display a progress dialog box.
Private Const FOF_RENAMEONCOLLISION = &H8        'Give the file being operated on a new name in a move, copy, or rename operation if a file with the target name already exists.
Private Const FOF_NOCONFIRMATION = &H10          'Respond with "Yes to All" for any dialog box that is displayed.
'Private Const FOF_WANTMAPPINGHANDLE = &H20      'fill in SHFILEOPSTRUCT.hNameMappings. Must be freed using SHFreeNameMappings
Private Const FOF_ALLOWUNDO = &H40               'Preserve undo information, if possible.
Private Const FOF_FILESONLY = &H80               'Perform the operation on files only if a wildcard file name (*.*) is specified.
Private Const FOF_SIMPLEPROGRESS = &H100         'Display a progress dialog box but do not show the file names.
Private Const FOF_NOCONFIRMMKDIR = &H200         'Do not confirm the creation of a new directory if the operation requires one to be created.
Private Const FOF_NOERRORUI = &H400              'Do not display a user interface if an error occurs.
Private Const FOF_NOCOPYSECURITYATTRIBS = &H800  'Version 4.71. Do not copy the security attributes of the file.
Private Const FOF_NORECURSION = &H1000           'Only operate in the local directory. Do not operate recursively into subdirectories.

Private Const FOF_NO_CONNECTED_ELEMENTS = &H2000 'Version 5.0. Do not copy connected files as a group. Only copy the specified files.
'Private Const FOF_WANTNUKEWARNING = &H4000      'During delete operation, warn if nuking instead of recycling (partially overrides FOF_NOCONFIRMATION)
'Private Const FOF_NORECURSEREPARSE = &H8000     'Treat reparse points as objects, not containers


Public Sub Create_Zip_Files()
    
    Dim PDFsFolder As String
    Dim ZIPsFolder As String
    Dim files As Variant
    Dim inputFiles As String, outputZipFile As String
    Dim prefix As String
    Dim i As Long
    
    PDFsFolder = "C:\path\to\PDF files\"    'CHANGE THIS - folder containing files to be zipped
    ZIPsFolder = "C:\path\to\zip files\"    'CHANGE THIS - folder in which output .zip files will be created
    
    If Right(PDFsFolder, 1) <> "\" Then PDFsFolder = PDFsFolder & "\"
    If Right(ZIPsFolder, 1) <> "\" Then ZIPsFolder = ZIPsFolder & "\"
    
    With ActiveSheet
        'Read values from columns A:B to files array.
        'The '+ 1' means the last row of the files array is empty to create a terminating value for the last group of input files in the For Next loop below
        files = .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
    End With
    
    prefix = ""
    inputFiles = ""
    For i = 1 To UBound(files)
        If Left(files(i, 1), 3) <> prefix Then
            If inputFiles <> "" Then
                Zip_Files inputFiles, outputZipFile
            End If
            prefix = Left(files(i, 1), 3)
            inputFiles = PDFsFolder & files(i, 1)
            outputZipFile = ZIPsFolder & files(i, 2)
        Else
            inputFiles = inputFiles & "|" & PDFsFolder & files(i, 1)
        End If
    Next
    
    MsgBox "Done"
    
End Sub


Private Sub Zip_Files(ByVal inputFiles As String, ByVal outputZipFile As Variant)

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim WShell As Object 'Shell32.Shell
    Dim WShtempFolder As Object 'Shell32.Folder
    Dim WShZipFolder As Object 'Shell32.Folder
    Dim file As Variant
    Dim CopyHereFlags As Variant
    Dim tempFolder As Variant, tempZipFolder As Variant

    tempFolder = Environ("temp")
    tempZipFolder = tempFolder & "\temp zip"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WShell = CreateObject("Shell.Application")
    
    'Create temporary folder to contain the files to be zipped.  If the temporary folder already exists it is deleted first
    
    If FSO.FolderExists(tempZipFolder) Then FSO.DeleteFolder tempZipFolder, True
    Set WShtempFolder = WShell.Namespace(tempFolder)
    WShtempFolder.NewFolder Mid(tempZipFolder, InStrRev(tempZipFolder, "\") + 1)
    Set WShtempFolder = WShell.Namespace(tempZipFolder)
    
    'Copy input files to the temporary folder. Duplicate file names are automatically renamed because the FOF_RENAMEONCOLLISION flag is specified
    
    CopyHereFlags = FOF_SILENT + FOF_RENAMEONCOLLISION + FOF_NOCONFIRMATION + FOF_NOERRORUI    
    For Each file In Split(inputFiles, "|")
        WShtempFolder.CopyHere file, CopyHereFlags
        DoEvents
    Next
    
    'Create new .zip file and copy all files in the temporary folder to it
    
    NewZip outputZipFile
    Set WShZipFolder = WShell.Namespace(outputZipFile)
    WShZipFolder.CopyHere WShtempFolder.Items, CopyHereFlags
    
    'Wait until all files are copied to the .zip file
    
    Do
        DoEvents
        Sleep 100
    Loop Until WShZipFolder.Items.Count = WShtempFolder.Items.Count
         
    Set FSO = Nothing
    Set WShell = Nothing
    
End Sub


'http://www.rondebruin.nl/win/s7/win001.htm
Private Sub NewZip(sPath)
    'Create empty Zip File
    'If Len(Dir(sPath)) > 0 Then Kill sPath
    On Error Resume Next 'trap 'Permission denied' error on Kill command
    While Len(Dir(sPath)) > 0 'ensure zip file is deleted
        Kill sPath
    Wend
    On Error GoTo 0
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub