Announcement

Collapse
No announcement yet.

Create Zip Files based on Cell Contents

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Create Zip Files based on Cell Contents



    Dear Seniors,

    I have a excel file where I have the list of File Path in Column A & list of File names in Column B, Default path location is available in Column C. Now I want create a zipped folder based on the file name in Column B to the location Column C. I had browsed in Internet and found some code for creating the zipped file by selecting the files in Windows browser window. However my case is need to create the Zipped file based on excel cell contents.

    I had found the code in the following location

    http://www.rondebruin.nl/win/s7/win001.htm

    However I need your help to create a code for creating the zipped folder based on Excel cell contents

    Thanks and Regards
    R. Vadivelan

  • #2
    Re: Create Zip Files based on Cell Contents

    Not tested.
    Code:
    Sub Zip_File_Or_Files()
        Dim WS As Worksheet
        Dim A As Long
        Dim LastRow As Long
        Dim strDate As String, DefPath As String, sFName As String
        Dim oApp As Object, iCtr As Long, I As Integer
        Dim FName, vArr, FileNameZip
    
    Set WS = Worksheet("Sheet1")
    With WS
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        For A = 2 To LastRow
        
            DefPath = .Range("C" & A)
            If Right(DefPath, 1) <> "\" Then
                DefPath = DefPath & "\"
            End If
        
            FileNameZip = DefPath & .Range("B" & A) & ".zip"
    
            'Create empty Zip File
            NewZip (FileNameZip)
            Set oApp = CreateObject("Shell.Application")
            I = 0
                If bIsBookOpen(.Range("B" & A)) Then
                    MsgBox "You can't zip a file that is open!" & vbLf & _
                           "Please close it and try again: " & FName(iCtr)
                Else
                    'Copy the file to the compressed folder
                    I = I + 1
                    oApp.Namespace(FileNameZip).CopyHere .Range("B" & A)
    
                    'Keep script waiting until Compressing is done
                    On Error Resume Next
                    Do Until oApp.Namespace(FileNameZip).items.Count = I
                        Application.Wait (Now + TimeValue("0:00:01"))
                    Loop
                    On Error GoTo 0
                End If
        Next
    
            MsgBox "You find the zipfile here: " & FileNameZip
        End If
    End Sub
    
    Sub NewZip(sPath)
    'Create empty Zip File
    'Changed by keepITcool Dec-12-2005
        If Len(Dir(sPath)) > 0 Then Kill sPath
        Open sPath For Output As #1
        Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
        Close #1
    End Sub

    Comment


    • #3
      Re: Create Zip Files based on Cell Contents

      Thanks Tinbendr,

      I will use this code and update you for any clarifications.

      Thanks and Regards
      R. Vadivelan

      Comment


      • #4
        Re: Create Zip Files based on Cell Contents

        Tinbendr,

        I had tried your code, I am getting error in the following line

        Set WS = Worksheet("Sheet1")

        Herewith I had enclosed my File image. Could you please check and advice me.

        Thanks and Regards
        R. VadivelanClick image for larger version

Name:	Capture.JPG
Views:	1
Size:	26.4 KB
ID:	1120127

        Comment


        • #5
          Re: Create Zip Files based on Cell Contents

          Change the name of Sheet1 to your named sheet.

          Comment


          • #6
            Re: Create Zip Files based on Cell Contents

            Hi Tinbendr,

            My sheet name is same as per default (i.e) Sheet1. But still I am getting the error

            Thanks and Regards
            R. Vadivelan

            Comment


            • #7
              Re: Create Zip Files based on Cell Contents

              Oops, sorry, typo.
              Code:
              Set WS = Worksheets("Sheet1")

              Comment


              • #8


                Re: Create Zip Files based on Cell Contents

                Hi Tinbendr,

                Thanks for your code. However I am still getting the error at "If bIsOpen". So I copied the sub functions from the website and corrected the code based on my experience. The following is the code Finally I have. When I run this code the blank Zip File is created but inside it there is no contents and it takes too much time. I have to interrupt only otherwise it keep on running.

                Code:
                Sub Zip_File_Or_Files()
                    Dim WS As Worksheet
                    Dim A As Long
                    Dim LastRow As Long
                    Dim strDate As String, DefPath As String, sFName As String
                    Dim oApp As Object, iCtr As Long, I As Integer
                    Dim FName, vArr, FileNameZip
                     
                    Set WS = Worksheets("Sheet1")
                    With WS
                        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                         
                        For A = 2 To LastRow
                             
                            DefPath = .Range("C" & A)
                            If Right(DefPath, 1) <> "\" Then
                                DefPath = DefPath & "\"
                            End If
                             
                            FileNameZip = DefPath & .Range("B" & A) & ".zip"
                             
                             'Create empty Zip File
                            NewZip (FileNameZip)
                            Set oApp = CreateObject("Shell.Application")
                            I = 0
                            If bIsBookOpen(.Range("B" & A)) Then
                                MsgBox "You can't zip a file that is open!" & vbLf & _
                                "Please close it and try again: " & FName(iCtr)
                            Else
                                 'Copy the file to the compressed folder
                                I = I + 1
                                oApp.Namespace(FileNameZip).CopyHere .Range("B" & A)
                                 
                                 'Keep script waiting until Compressing is done
                                On Error Resume Next
                                Do Until oApp.Namespace(FileNameZip).items.Count = I
                                    Application.Wait (Now + TimeValue("0:00:01"))
                                Loop
                                On Error GoTo 0
                            End If
                        Next
                         
                        MsgBox "You find the zipfile here: " & FileNameZip
                        End With
                End Sub
                 
                Sub NewZip(sPath)
                     'Create empty Zip File
                     'Changed by keepITcool Dec-12-2005
                    If Len(Dir(sPath)) > 0 Then Kill sPath
                    Open sPath For Output As #1
                    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
                    Close #1
                End Sub
                Function bIsBookOpen(ByRef szBookName As String) As Boolean
                ' Rob Bovey
                    On Error Resume Next
                    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
                End Function
                Function Split97(sStr As Variant, sdelim As String) As Variant
                'Tom Ogilvy
                    Split97 = Evaluate("{""" & _
                                       Application.Substitute(sStr, sdelim, """,""") & """}")
                End Function
                In the same website I found the following code

                Zip all files in the folder that you enter in the code

                Note: Before you run the macro below change the folder in this macro line
                FolderName = "C:\Users\Ron\test\"

                Code:
                 	Sub Zip_All_Files_in_Folder()
                    Dim FileNameZip, FolderName
                    Dim strDate As String, DefPath As String
                    Dim oApp As Object
                
                    DefPath = Application.DefaultFilePath
                    If Right(DefPath, 1) <> "\" Then
                        DefPath = DefPath & "\"
                    End If
                
                    FolderName = "C:\Users\Ron\test\"    '<< Change
                
                    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
                    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
                
                    'Create empty Zip File
                    NewZip (FileNameZip)
                
                    Set oApp = CreateObject("Shell.Application")
                    'Copy the files to the compressed folder
                    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
                
                    'Keep script waiting until Compressing is done
                    On Error Resume Next
                    Do Until oApp.Namespace(FileNameZip).items.Count = _
                       oApp.Namespace(FolderName).items.Count
                        Application.Wait (Now + TimeValue("0:00:01"))
                    Loop
                    On Error GoTo 0
                
                    MsgBox "You find the zipfile here: " & FileNameZip
                End Sub
                I understood that this file will Zip all the Files in the Folder. Is it possible to create the Zip files for the sub Folders separately. I tried this code it makes the single Zip file including the Subfolders. Whereus in my case I need to create the Zip files for Sub Folders. If it is done my problem will be solved.

                Thanks in Advance for your Help
                Regards
                R. Vadivelan

                Comment

                Working...
                X