Find customer in column & link to his pdf

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,715
Office Version
  1. 2007
Platform
  1. Windows
I have the following code in use.
Thought this was sorted but code doesnt find correct customer in column B.

I am in workbook DISCO CALC & on sheet PRINT LABELS
I run the code below where the user selects a customer from a userform drop down,this is populated from workbook called DR sheet postage
After the customer is selected his pdf is saved no problem & his name is entered in cell B3

Now the code opens workbook DR & selects sheet POSTAGE, so far all done is correct.
This is the issue.

The code is supposed to find the customer from cell B3 "on the previous sheet in this case TOM JONES" in column B of POSTAGE
Once found a userform will open where the user is asked to hyperlink the found customer.

The issue is that the code selects the last name in column B as ooposed to the customer TOM JONES.



VBA Code:
Private Sub PurchasedKey_Click()
  Dim sPath As String
  Dim strFileName As String
  Dim sh As Worksheet
  Dim wb As Workbook
 
  With ActiveSheet
    If .Range("Q1") = "" Then
      MsgBox "NO CODE SHOWN TO GENERATE PDF", vbCritical, "NO CODE ON SHEET TO CREATE PDF"
      Exit Sub
    End If
    
    If .Range("N1") = "M" Then
       strFileName = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\" & .Range("B3").Value & " (SLS).pdf"
    Else
       strFileName = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\" & .Range("B3").Value & ".pdf"
    End If
          
    If Dir(strFileName) = "" Then
      .Range("A1:K23").ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
       MsgBox "PDF FILE HAS NOW BEEN SAVED", vbInformation + vbOKOnly, "SAVED PDF FILE MESSAGE"
      
       With ActiveSheet
    'ActiveWindow.SelectedSheets.PrintOut copies:=1
    Unload PrinterForm
    
        .Range("B3").Select
        Application.ScreenUpdating = False
    Dim C As Range
    Dim ans As String
    Dim Lastrow As Long
        ans = ActiveCell.Value
        Set wb = Application.Workbooks.Open("C:\Users\Ian\Desktop\REMOTES ETC\DR\DR.xlsm")
        Lastrow = Sheets("POSTAGE").Cells(Rows.Count, "B").End(xlUp).Row
        
    For Each C In Sheets("POSTAGE").Range("B1:B" & Lastrow)
    If C.Value = ans Then
        Application.Goto Reference:=wb.Sheets("POSTAGE").Range(C.Address)
        ActiveWindow.ScrollColumn = 1
    Exit For
    End If
    
    Next

    End With
    
          Application.Run ("'" & wb.Name & "'!openForm")
          Application.ScreenUpdating = True
      
    Else
        'IF FILE IS PRESENT DO NOT ALLOW FILE TO BE OVERWRITTEN & TO SHOW MSGBOX
        MsgBox "CUSTOMERS FILE HAS ALLREADY BEEN SAVED", vbCritical + vbOKOnly, "FILE ALLREADY SAVED MESSAGE"
            
    Dim strFolder As String
        strFolder = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\"
        ActiveWorkbook.FollowHyperlink Address:=strFolder, NewWindow:=True
        Unload PrinterForm
    End If
        
    Exit Sub
          End With
End Sub
 
Just a thought.
As opposed to matching the customer then adding a hyperlink why not once the pdf has been saved etc open workbook DR, select sheet POSTAGE then with the code if customers name is present in column B & in given path / folder then apply hyperlink that customer.

The code should look last row then up the page in column B
Maybe only look in last 10 rows as this will be fine.

I think this is the easier way to fix it.
 
Upvote 0

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
The issue is that whatever you are putting into workbook DISCO CALC sheet PRINT LABELS cell B3
doesn't exist in workbook DR sheet POSTAGE column B
or the STOP instruction that was added would be stopping the code execution at that point.
 
Upvote 0
But it does.
Look here at my work flow.

POSTAGE sheet customers details are added then saved to worksheet.

EaseUS_2024_07_28_21_56_23.jpg


I then open DISCO CALC sheet.Combox is populated with last 6 / 7 names from column B on POSTAGE sheet.

EaseUS_2024_07_28_21_57_45.jpg


Once im done there the name STEVE JONES 001 is placed in cell B3

EaseUS_2024_07_28_21_58_23.jpg


Here is the saved pdf file for STEVE JONES 001

EaseUS_2024_07_28_21_58_56.jpg



Here is my code put back to how it was.
So as a test can you edit please to do this, Lets forget the value in cell B3
When the POSTAGE sheet is open & column B is used the code will look for any customer that is in column B,last row & up say 10 rows that are also in this folder & if present hyperlink them.

Path to folder where pdf are kept.
C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF

Lets assume all but one have been hyperlinked before.The code looks at the names & can see that STEVE JONES 001 is in the folder where the pdf are kept so it the applies a hyperlink to STEVE JONES 001 in column B

So now when i click STEVE JONES 001 in column B the pdf for STEVE JONES 001 in the pdf folder opens.

Job done.

No need for B3 vakue anymore just have the code check names in column B against what is in the pdf folder & hyperlink if needed.



VBA Code:
Private Sub PurchasedKey_Click()
  Dim sPath As String
  Dim strFileName As String
  Dim sh As Worksheet
  Dim wb As Workbook
 
    With ActiveSheet
    If .Range("Q1") = "" Then
      MsgBox "NO CODE SHOWN TO GENERATE PDF", vbCritical, "NO CODE ON SHEET TO CREATE PDF"
      Exit Sub
    End If
    
    If .Range("N1") = "M" Then
       strFileName = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\" & .Range("B3").Value & " (SLS).pdf"
    Else
       strFileName = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\" & .Range("B3").Value & ".pdf"
    End If
          
    If Dir(strFileName) = "" Then
      .Range("A1:K23").ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
       MsgBox "PDF FILE HAS NOW BEEN SAVED", vbInformation + vbOKOnly, "SAVED PDF FILE MESSAGE"
      
    With ActiveSheet
    'ActiveWindow.SelectedSheets.PrintOut copies:=1
    Unload PrinterForm
    
        .Range("B3").Select
        Application.ScreenUpdating = False
    Dim C As Range
    Dim ans As String
    Dim Lastrow As Long
        ans = ActiveCell.Value
        
        
    Set wb = Application.Workbooks.Open("C:\Users\Ian\Desktop\REMOTES ETC\DR\DR.xlsm")
        Lastrow = Sheets("POSTAGE").Cells(Rows.Count, "B").End(xlUp).Row
        
        
    For Each C In Sheets("POSTAGE").Range("B1:B" & Lastrow)
    If C.Value = ans Then
        Application.Goto Reference:=wb.Sheets("POSTAGE").Range(C.Address)
        ActiveWindow.ScrollColumn = 1
    Exit For
    End If
    
    Next

    End With
    
          Application.Run ("'" & wb.Name & "'!openForm")
          Application.ScreenUpdating = True
      
    Else
        'IF FILE IS PRESENT DO NOT ALLOW FILE TO BE OVERWRITTEN & TO SHOW MSGBOX
        MsgBox "CUSTOMERS FILE HAS ALLREADY BEEN SAVED", vbCritical + vbOKOnly, "FILE ALLREADY SAVED MESSAGE"
            
    Dim strFolder As String
        strFolder = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\"
        ActiveWorkbook.FollowHyperlink Address:=strFolder, NewWindow:=True
        Unload PrinterForm
    End If
        
    Exit Sub
          End With
End Sub
 
Upvote 0
This works for me but ned an edit please.
The edit being only check last 10 rows to hyperlink,no need for the code to check 2250 rows

Thanks for your help with this

VBA Code:
Private Sub PurchasedKey_Click()
  Dim sPath As String
  Dim strFileName As String
  Dim sh As Worksheet
  Dim wb As Workbook
 
    With ActiveSheet
    If .Range("Q1") = "" Then
      MsgBox "NO CODE SHOWN TO GENERATE PDF", vbCritical, "NO CODE ON SHEET TO CREATE PDF"
      Exit Sub
    End If
    
    If .Range("N1") = "M" Then
       strFileName = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\" & .Range("B3").Value & " (SLS).pdf"
    Else
       strFileName = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\" & .Range("B3").Value & ".pdf"
    End If
          
    If Dir(strFileName) = "" Then
      .Range("A1:K23").ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
       MsgBox "PDF FILE HAS NOW BEEN SAVED", vbInformation + vbOKOnly, "SAVED PDF FILE MESSAGE"
      
    With ActiveSheet
    'ActiveWindow.SelectedSheets.PrintOut copies:=1
    Unload PrinterForm
    
    Set wb = Application.Workbooks.Open("C:\Users\Ian\Desktop\REMOTES ETC\DR\DR.xlsm")
             Worksheets("POSTAGE").Activate
    
            Application.Goto Sheets("POSTAGE").Range("A" & Rows.Count).End(xlUp), True
            ActiveWindow.SmallScroll UP:=14
    
    End With
    End If
    End With
    
    Call DISCOHYPERLINK

End Sub

Call DISCOHYPERLINK code is as follows
Code:
Sub DISCOHYPERLINK()
    Const sPath As String = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\"
  Dim sFile As String, i As Long
  With Sheets("POSTAGE")
    For i = 2 To .Range("B" & Rows.Count).End(3).Row
      sFile = sPath & .Range("B" & i).Value & ".pdf"
      If Len(Dir(sFile)) Then
        .Range("B" & i).Hyperlinks.Add Anchor:=.Range("B" & i), Address:=sFile
      End If
    Next
  End With
  MsgBox "CUSTOMER WAS HYPERLINKED.", vbInformation, "DISCO II HYPERLINK MESSAGE"
End Sub
 
Upvote 0
VBA Code:
Dim lastrow as Long  
With Sheets("POSTAGE")
    lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = lastrow - 10 To lastrow
 
Upvote 0
Morning.

The code with the added code above is supplied but i am seeing i is not defined.
Please advise what i should change / add to the code.
Thanks

For future reference how do i know what im supposed anyway ?

VBA Code:
Sub DISCOHYPERLINK()
  Dim lastrow As Long
  With Sheets("POSTAGE")
    lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = lastrow - 10 To lastrow
    
    Const sPath As String = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\"
  Dim sFile As String, i As Long
  With Sheets("POSTAGE")
    For i = 2 To .Range("B" & Rows.Count).End(3).Row
      sFile = sPath & .Range("B" & i).Value & ".pdf"
      If Len(Dir(sFile)) Then
        .Range("B" & i).Hyperlinks.Add Anchor:=.Range("B" & i), Address:=sFile
      End If
    Next
  End With
  MsgBox "CUSTOMER WAS HYPERLINKED.", vbInformation, "DISCO II HYPERLINK MESSAGE"
End Sub
 
Upvote 0
VBA Code:
Sub DISCOHYPERLINK()
    Const sPath As String = "C:\Users\Ian\Desktop\REMOTES ETC\DISCO II CODE\DISCO II PDF\"
  Dim sFile As String, i As Long
  
  Dim lastrow As Long
  With Sheets("POSTAGE")
    lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = lastrow - 10 To lastrow
    
      sFile = sPath & .Range("B" & i).Value & ".pdf"
      If Len(Dir(sFile)) Then
        .Range("B" & i).Hyperlinks.Add Anchor:=.Range("B" & i), Address:=sFile
      End If
    Next
  End With
  MsgBox "CUSTOMER WAS HYPERLINKED.", vbInformation, "DISCO II HYPERLINK MESSAGE"
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,402
Messages
6,171,915
Members
452,432
Latest member
TiffanyMcllwain

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top