Zip series of files with same prefix in the same folder

[lidovi]

Hello. I need help coding to zip files with same prefix in name.

Every day, I receive 200 files like these in 1 folder:

1111111111_1321435435_HD_SL.pdf​

1111111111_1321435436_HD_SL.pdf​

1111111111_1321435437_HD_SL.pdf​

2222222222_2542875575_HD_SL.pdf​

2222222222_2542875576_HD_SL.pdf​

I manually look for files with the same prefix, zip them together and delete the original .PDF files afterwards.

For example:​

1111111111_1321435435_HD_SL.pdf​

1111111111_1321435436_HD_SL.pdf​

1111111111_1321435437_HD_SL.pdf​

will go to 1111111111.zip​

Is it possible to automatically do this process using VBA? Many thanks!

 

[John_w]

Welcome to MrExcel forums.

Try running this macro on a copy of the folder containing the .pdf files.

Option Explicit

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


Public Sub Zip_File_Groups()

    Dim sourceFolder As String
    Dim file As String
    Dim p As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select folder containing files to be zipped"
        .InitialFileName = ThisWorkbook.Path
        If Not .Show Then Exit Sub
        sourceFolder = .SelectedItems(1) & "\"
    End With
    
    file = Dir(sourceFolder & "*.pdf")
    While file <> vbNullString
        p = InStr(file, "_")
        Zip_File sourceFolder & file, sourceFolder & Left(file, p - 1) & ".zip"
        file = Dir
    Wend

End Sub


Public Sub Zip_File(sourceFile As String, zipFile As Variant)

    Dim Sh As Object
    Dim ShZipFolder As Object
    Dim ShFolderItem As Object
    Dim sourceFolder As Variant, sourceFileName As Variant
    
    sourceFolder = Left(sourceFile, InStrRev(sourceFile, "\"))
    sourceFileName = Mid(sourceFile, InStrRev(sourceFile, "\") + 1)

    Set Sh = CreateObject("Shell.Application")
    
    With Sh
    
        Set ShZipFolder = .Namespace(zipFile)
        If ShZipFolder Is Nothing Then
            NewZip zipFile
            Set ShZipFolder = .Namespace(zipFile)
        End If
    
        Set ShFolderItem = .Namespace(sourceFolder).Items().Item(sourceFileName)
        ShZipFolder.MoveHere ShFolderItem
        
        DoEvents
        Sleep 500
    
    End With

End Sub


'http://www.rondebruin.nl/win/s7/win001.htm
Private Sub NewZip(sPath As Variant)
    'Create empty Zip File
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

 

[lidovi]

Welcome to MrExcel forums.

Try running this macro on a copy of the folder containing the .pdf files.

Option Explicit

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


Public Sub Zip_File_Groups()

    Dim sourceFolder As String
    Dim file As String
    Dim p As Long
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select folder containing files to be zipped"
        .InitialFileName = ThisWorkbook.Path
        If Not .Show Then Exit Sub
        sourceFolder = .SelectedItems(1) & "\"
    End With
   
    file = Dir(sourceFolder & "*.pdf")
    While file <> vbNullString
        p = InStr(file, "_")
        Zip_File sourceFolder & file, sourceFolder & Left(file, p - 1) & ".zip"
        file = Dir
    Wend

End Sub


Public Sub Zip_File(sourceFile As String, zipFile As Variant)

    Dim Sh As Object
    Dim ShZipFolder As Object
    Dim ShFolderItem As Object
    Dim sourceFolder As Variant, sourceFileName As Variant
   
    sourceFolder = Left(sourceFile, InStrRev(sourceFile, "\"))
    sourceFileName = Mid(sourceFile, InStrRev(sourceFile, "\") + 1)

    Set Sh = CreateObject("Shell.Application")
   
    With Sh
   
        Set ShZipFolder = .Namespace(zipFile)
        If ShZipFolder Is Nothing Then
            NewZip zipFile
            Set ShZipFolder = .Namespace(zipFile)
        End If
   
        Set ShFolderItem = .Namespace(sourceFolder).Items().Item(sourceFileName)
        ShZipFolder.MoveHere ShFolderItem
       
        DoEvents
        Sleep 500
   
    End With

End Sub


'http://www.rondebruin.nl/win/s7/win001.htm
Private Sub NewZip(sPath As Variant)
    'Create empty Zip File
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

It worked like a charm! Thank you so much! You just saved me from 2 hours of manual work.