Script works but skips files in defined range.

**stevedeer** · 04-01-2016, 11:03 AM

Hello.

I need help with this bit of VBA. The script executes successfully but it skips some files about 259 out of 350 are getting copied. All links have been validated and work.

Any feedback will be much appreciated.

Public Sub CopyFile()
    Dim rng As Range
    Const strNewDir As String = "D:\test\"

    For Each rng In Range("L9:L1017").SpecialCells(xlCellTypeVisible)
        If CBool(rng.Hyperlinks.Count) Then
            With rng.Hyperlinks(1)
                If CBool(InStr(.Address, Chr(92))) Then
                    FileCopy .Address, _
                      strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                Else
                    FileCopy .Address, _
                      strNewDir & .Address
                End If
             End With
        End If
    Next rng
    
End Sub

**Bernie Deitrick** · 04-01-2016, 12:21 PM

Do you have any files with the same names, but in different folders? Check for existence before copying, and if they exist, then create a unique name

Public Sub CopyFile2()
    Dim rng As Range
    Const strNewDir As String = "D:\test\"
    
    For Each rng In Range("L9:L1017").SpecialCells(xlCellTypeVisible)
        If CBool(rng.Hyperlinks.Count) Then
            With rng.Hyperlinks(1)
                If CBool(InStr(.Address, Chr(92))) Then
                    If Dir(strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))) = "" Then
                        FileCopy .Address, _
                        strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                    Else
                        FileCopy .Address, _
                        strNewDir & rng.Row & "-" & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                    End If
                Else
                    If Dir(strNewDir & .Address) = "" Then
                        FileCopy .Address, _
                        strNewDir & .Address
                    Else
                        FileCopy .Address, _
                        strNewDir & rng.Row & "-" & .Address
                    End If
                End If
            End With
        End If
    Next rng
    
End Sub

**AlphaFrog** · 04-01-2016, 12:42 PM

I'm not sure wht the problem is. Bernie's suggestion sounds plausible. Also consider duplicate hyperlinks within the Range? I would suspect the issue is with the Hyperlinks, the Range, or the files, and not so much with the VBA code itself.

On another note, you can loop through the hyperlinks within your visible range using the hyperlinks collection...

Public Sub CopyFile()
    Dim hl As Hyperlink
    Const strNewDir As String = "C:\test\"
    
    For Each hl In Range("L9:L1017").SpecialCells(xlCellTypeVisible).Hyperlinks
        If InStr(hl.Address, Chr(92)) Then
            FileCopy .Address, _
              strNewDir & Mid(hl.Address, InStrRev(hl.Address, Chr(92)) + 1)
        Else
            FileCopy .Address, _
              strNewDir & hl.Address
        End If
    Next hl
End Sub

**stevedeer** · 04-01-2016, 12:47 PM

Ok it brings in the right number of files now however it is duplicating pdfs for some reason. I have verified that each hyperlink is unique and the file names in the source locations are unique from each other.

Example below is a list that i tested this on. Originally my script would only bring in the first pdf in the list. Now with Bernies updated script it looks at all the instances but duplicates the first PDF and

Sources its looking at.

..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HL.pdf
..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HL-I.pdf
..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HM.pdf
..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HM-I.pdf
..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HS.pdf
..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HS-I.pdf

What it pastes in folder. It uses same pdf and adds the row number to beginning. Its like its not reading the Characters in the hyperlinks past the HL.

01 - Controller - Delta - DOW-340-HL.pdf
36-01 - Controller - Delta - DOW-340-HL.pdf
37-01 - Controller - Delta - DOW-340-HL.pdf
38-01 - Controller - Delta - DOW-340-HL.pdf
39-01 - Controller - Delta - DOW-340-HL.pdf
40-01 - Controller - Delta - DOW-340-HL.pdf

**Bernie Deitrick** · 04-01-2016, 04:08 PM

I am guessing that you copied your hyperlinks and changed the display string but not the actual file address. Look in cells L36, 37, 38, 39, and 40.

Otherwise, there are errors and the .Address value is somehow not being properly updated from those cells.

What does this show?

Sub FindTheError()
Dim strv As String
strv = Range("L36").Hyperlinks(1).Address & Chr(10) & Range("L37").Hyperlinks(1).Address
MsgBox strv
End Sub

**stevedeer** · 04-01-2016, 04:15 PM

So when I run your error check it brings back this.

..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HL.pdf
..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HL.pdf

but when i click on the link it takes me to the right file and then also when i go into edit hyper link it gives me this as the address for each

..\..\..\..\Cutsheets\Delta\Software\01%20-%20Controller%20-%20Delta%20-%20DOW-340-HL-I.pdf
..\..\..\..\Cutsheets\Delta\Software\01%20-%20Controller%20-%20Delta%20-%20DOW-340-HM.pdf

**Bernie Deitrick** · 04-01-2016, 04:20 PM

How about?

Sub FindTheError2()
Dim strv As String
strv = Range("L36").Hyperlinks.Count & Chr(10) & Range("L37").Hyperlinks.Count
MsgBox strv
End Sub

**stevedeer** · 04-01-2016, 04:24 PM

Gives back
2
2

**Bernie Deitrick** · 04-01-2016, 04:40 PM

I think that having more than 1 hyperlink in a cell is the source of your error - you are always assuming Hyperlink(1) is correct (and I honestly don't know how to add two hyperlinks to one cell....)

Sub FindTheError3()
    Dim strv As String
    strv = "L36-1: " & Range("L36").Hyperlinks(1).Address & Chr(10) & _
    "L36-2: " & Range("L36").Hyperlinks(2).Address & Chr(10) & _
    "L37-1: " & Range("L37").Hyperlinks(1).Address & Chr(10) & _
    "L37-2: " & Range("L37").Hyperlinks(2).Address
    MsgBox strv
End Sub

Maybe it can all be fixed if you change

        If CBool(rng.Hyperlinks.Count) Then
            With rng.Hyperlinks(1)

to

        If CBool(rng.Hyperlinks.Count) Then
            With rng.Hyperlinks(rng.Hyperlinks.Count)

**stevedeer** · 04-04-2016, 09:07 AM

This worked out. And yes running the new FindError script did reveal multiple associated hyperlinks.

How is that possible? I can not find where the extra links exist. I assume it may be from the original document creator copying and pasting.

What can I do in the future to avoid this?

**Bernie Deitrick** · 04-04-2016, 10:35 AM

Try running this to clean out the extra HLs: I have assumed that later HLs are the desired HLs.

Public Sub DeleteExtraHLs()
    Dim rng As Range
    Dim i As Integer

    For Each rng In Intersect(Range("L:L"), ActiveSheet.UsedRange)
        If rng.Hyperlinks.Count > 1 Then
            For i = 1 To rng.Hyperlinks.Count - 1
                rng.Hyperlinks(1).Delete
            Next i
        End If
    Next rng
    
End Sub

**stevedeer** · 04-04-2016, 11:04 AM

Great thanks

So know I have modified the code to create a Dir and then put the files in that Dir.

It worked initially multiple times and tests runs with no issues but once it was saved down, closed, and reoppened it errors out on file path not found for the Mkdir command.

To help I am running this off a Networked drive.

Public Sub CopyFile2()
    MkDir ("..\Submittal packaged\BOM PDF")
    Dim rng As Range
    Const strNewDir As String = "..\Submittal Packaged\BOM PDF\"
    
    For Each rng In Range("L9:L1042").SpecialCells(xlCellTypeVisible)
        If CBool(rng.Hyperlinks.Count) Then
            With rng.Hyperlinks(rng.Hyperlinks.Count)
                If CBool(InStr(.Address, Chr(92))) Then
                    If Dir(strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))) = "" Then
                        FileCopy .Address, _
                        strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                    Else
                        FileCopy .Address, _
                        strNewDir & rng.Row & "-" & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                    End If
                Else
                    If Dir(strNewDir & .Address) = "" Then
                        FileCopy .Address, _
                        strNewDir & .Address
                    Else
                        FileCopy .Address, _
                        strNewDir & rng.Row & "-" & .Address
                    End If
                End If
            End With
        End If
    Next rng
End Sub

**stevedeer** · 04-04-2016, 11:05 AM

Great thanks

So now I have modified the code to create a Dir and then put the files in that Dir.

It worked initially multiple times and tests runs with no issues but once it was saved down, closed, and reoppened it errors out on file path not found for the Mkdir command.

To help I am running this off a Networked drive.

Public Sub CopyFile2()
    MkDir ("..\Submittal packaged\BOM PDF")
    Dim rng As Range
    Const strNewDir As String = "..\Submittal Packaged\BOM PDF\"
    
    For Each rng In Range("L9:L1042").SpecialCells(xlCellTypeVisible)
        If CBool(rng.Hyperlinks.Count) Then
            With rng.Hyperlinks(rng.Hyperlinks.Count)
                If CBool(InStr(.Address, Chr(92))) Then
                    If Dir(strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))) = "" Then
                        FileCopy .Address, _
                        strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                    Else
                        FileCopy .Address, _
                        strNewDir & rng.Row & "-" & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                    End If
                Else
                    If Dir(strNewDir & .Address) = "" Then
                        FileCopy .Address, _
                        strNewDir & .Address
                    Else
                        FileCopy .Address, _
                        strNewDir & rng.Row & "-" & .Address
                    End If
                End If
            End With
        End If
    Next rng
End Sub

**Bernie Deitrick** · 04-04-2016, 11:25 AM

Is the error because the folder exists?

    If Dir("..\Submittal packaged\BOM PDF", vbDirectory) = "" Then
        MkDir ("..\Submittal packaged\BOM PDF")
    End If

Or that the network folder is not the default drive? Then, the ..\ will not work - not sure what your network drive is named....

ChDrive ("M:\")

**stevedeer** · 04-04-2016, 11:31 AM

The folder does not exist. I did try the If statement method prior to posting and got same error.

What has been discovered is when ?CurDir is run in Immediate window my local drive pops up... Is there a way to get excel to recognize the path from which it was launched?

Also the current network drive letter is Y:

C:\Users\steve\Documents

**stevedeer** · 04-04-2016, 11:50 AM

Figured it out

ChDrive "y:"
    ChDir ThisWorkbook.Path

**Bernie Deitrick** · 04-04-2016, 11:53 AM

ChDrive ("Y:\")
'or..
MkDir ("Y:\Submittal packaged\BOM PDF")

**stevedeer** · 04-05-2016, 11:24 AM

Ok so everything is working greqat now except when I save and close out now the hyperlin address path errors out. However if I click the hyperlinks and navigate to the document manually and then run script again it all updates successfully and runs.

Any idea what could be causing that?

**Bernie Deitrick** · 04-05-2016, 12:02 PM

I think that it is the ..\ part of the file path. You either need to set an absolute path "Y:\folder...." or change to the correct directory tree when the file is opened. You could use

Private Sub Workbook_Open()
ChDrive "Y:\"
End Sub

In the codemodule of the ThisWorkbook object.

**stevedeer** · 04-05-2016, 02:55 PM

Ok so below is the original code and now it calls a new Sub that takes pdfs from one location based on a visible cell range and then put them in the directory and then calls another module to merge the pdfs. In the second module there is a variable strPath that when the full folder path is defined it works fine. However trying to use a structure like "..\Submittal Packaged\BOM PDF\" it gets stuck in the while loop. I have debugged and watched it step through and find every pdf file in the folder but instead of not seeing the end it loops back to the beginning.

The below code is configured in the way I am having issues.

    Option Explicit ' Force variable declaration
    Public Const PDF_WILDCARD = "*.pdf"
    Public Const JOIN_FILENAME = "MASTER BOM.pdf"
    Public Sub CopyFile2()
        ChDrive "y:"
        ChDir ThisWorkbook.Path
        MkDir ("..\Submittal Packaged\BOM PDF\")
        Dim rng As Range
        Const strNewDir As String = "..\Submittal Packaged\BOM PDF\"
        
        For Each rng In Range("L9:L1042").SpecialCells(xlCellTypeVisible)
            If CBool(rng.Hyperlinks.Count) Then
                With rng.Hyperlinks(rng.Hyperlinks.Count)
                    If CBool(InStr(.Address, Chr(92))) Then
                        If Dir(strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))) = "" Then
                            FileCopy .Address, _
                            strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                        Else
                            FileCopy .Address, _
                            strNewDir & rng.Row & "-" & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))
                        End If
                    Else
                        If Dir(strNewDir & .Address) = "" Then
                            FileCopy .Address, _
                            strNewDir & .Address
                        Else
                            FileCopy .Address, _
                            strNewDir & rng.Row & "-" & .Address
                        End If
                    End If
                End With
            End If
        Next rng
    Call mergepdf
    End Sub
    
    Sub mergepdf()
        Dim AcroExchApp As Object, AcroExchPDDoc As Object, _
            AcroExchInsertPDDoc As Object
        Dim strFileName As String, strPath As String
        Dim iNumberOfPagesToInsert As Integer, _
            iLastPage As Integer
        Set AcroExchApp = CreateObject("AcroExch.App")
        Set AcroExchPDDoc = CreateObject("AcroExch.PDDoc")
        ChDrive "y:"
    
    ' Set the directory / folder to use
        strPath = "..\Submittal Packaged\BOM PDF\"
    
    ' Get the first pdf file in the directory
        strFileName = Dir(strPath + PDF_WILDCARD, vbNormal)
    
    ' Open the first file in the directory
        AcroExchPDDoc.Open strPath + strFileName
        
    ' Get the name of the next file in the directory [if any]
        If strFileName <> "" Then
            strFileName = Dir
       
        ' Start the loop.
            Do While strFileName <> ""
        
        ' Get the total pages less one for the last page num [zerobased]
                iLastPage = AcroExchPDDoc.GetNumPages - 1
                Set AcroExchInsertPDDoc = CreateObject("AcroExch.PDDoc")
            
            ' Open the file to insert
                AcroExchInsertPDDoc.Open strPath + strFileName
    
            ' Get the number of pages to insert
                iNumberOfPagesToInsert = AcroExchInsertPDDoc.GetNumPages
    
            ' Insert the pages
            AcroExchPDDoc.InsertPages iLastPage, AcroExchInsertPDDoc, 0, iNumberOfPagesToInsert, True
        
            ' Close the document
                AcroExchInsertPDDoc.Close
        
           ' Get the name of the next file in the directory
                strFileName = Dir
                 Loop
            
        ' Save the entire document as the JOIN_FILENAME using SaveFull
    [0x0001 = &H1]
            AcroExchPDDoc.Save &H1, strPath + JOIN_FILENAME
    
    End If
    
    ' Close the PDDoc
        AcroExchPDDoc.Close
            
    ' Close Acrobat Exchange
        AcroExchApp.Exit
    End Sub

Script works but skips files in defined range.

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Re: Script works but skips files in defined range.

Thread Information

Users Browsing this Thread

Similar Threads

Copying down a formula that skips a set amount in the range

Macro for inserting rows w/ data works fine for 4iterations, but skips updates in 5th

Script skips past numbers in an array.

[SOLVED] If word entered not in defined name range, copy & paste it to bottom of defined name range

Script works on XP but not on Win4

Opening files from defined range

Range.Find skips the first cell ??

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions