Optimize lookup macro

[nicnad]

Hi,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I've been working on some code for a worksheet. The way I would like it to work is when the user copy paste a file path in column "E", it autofills some cell based on preset value/formula. Here is the code i have so far. First, for some reason the worksheet_change event is not triggered on a copy paste on column "e". I need to manually make a change to a cell in column "E" for the macro to start running. Second, the code seems to have a bug in it and I need to doubleclick to stop it running, but after I do so, all the right information appear in every cell. I'm a beginner VBA programmer and I know this code isn't well written. Could you please help me optimize it and fix the problems mentionned above. Thank you very much for your help. Here is the code :

Private Sub Worksheet_Change(ByVal Target As Range) <o:p></o:p>
Dim lastrowe <o:p></o:p>
lastrowe = Worksheets("Documents").Cells(Rows.Count, "e").End(xlUp).Row <o:p></o:p>
On Error Resume Next <o:p></o:p>
Application.EnableEvents = False <o:p></o:p>
Application.ScreenUpdating = False <o:p></o:p>
If Target.Column = 5 Then <o:p></o:p>
    Range("l2:l999").ClearContents <o:p></o:p>
    Dim i As Long <o:p></o:p>
    For i = 2 To lastrowe <o:p></o:p>
        Cells(i, "a").Formula = "=TRIM(MID(SUBSTITUTE(e" & i & ",""\"",REPT("" "",200)),400,200))" <o:p></o:p>
        Cells(i, "b").Formula = "=findgroup(a" & i & ")" <o:p></o:p>
        Cells(i, "c").Formula = "=findcountry(a" & i & ")" <o:p></o:p>
        Cells(i, "d").Formula = "=findentity(a" & i & ")" <o:p></o:p>
        Cells(i, "l").Value = "=if(isna(vlookups('Schedule'!$a$2:$d$999,d" & i & ",1,f" & i & ",3)),""NO"",""YES"")" <o:p></o:p>
    Next <o:p></o:p>
    addborders <o:p></o:p>
    Range("e" & lastrowe).Select <o:p></o:p>
    Application.EnableEvents = True <o:p></o:p>
    Application.ScreenUpdating = True <o:p></o:p>
End If <o:p></o:p>
End Sub <o:p></o:p>
<o:p>

</o>
<o></o>
the functions findgroup, findcountry, and findentity are all functions based on this code (were the case are the same and are repeated, it is just the value that changes), and have about 10 cases each :<o></o>

Function findgroup(strString As String) As String <o:p></o:p>
 <o:p></o:p>
Select Case strString <o:p></o:p>
     <o:p></o:p>
Case "name1" <o:p></o:p>
    findgroup = "abc" <o:p></o:p>
     <o:p></o:p>
Case "name2" <o:p></o:p>
    findgroup = "xyz" <o:p></o:p>
     <o:p></o:p>
Case "name3" <o:p></o:p>
    findgroup = "ccc" <o:p></o:p>
     <o:p></o:p>
End Select <o:p></o:p>
End Function <o:p></o:p>
<o:p></o:p>
Function findcountry(strString As String) As String <o:p></o:p>
 <o:p></o:p>
Select Case strString <o:p></o:p>
     <o:p></o:p>
Case "name1" <o:p></o:p>
    findgroup = "country Z" <o:p></o:p>
     <o:p></o:p>
Case "name2" <o:p></o:p>
    findgroup = "country Y" <o:p></o:p>
     <o:p></o:p>
Case "name3" <o:p></o:p>
    findgroup = "country X" <o:p></o:p>
     <o:p></o:p>
End Select <o:p></o:p>
End Function <o:p></o:p>
<o:p></o:p>
Function findentity(strString As String) As String <o:p></o:p>
 <o:p></o:p>
Select Case strString <o:p></o:p>
     <o:p></o:p>
Case "name1" <o:p></o:p>
    findgroup = "entity ABC" <o:p></o:p>
     <o:p></o:p>
Case "name2" <o:p></o:p>
    findgroup = "entity 1234" <o:p></o:p>
     <o:p></o:p>
Case "name3" <o:p></o:p>
    findgroup = "entity XYZ" <o:p></o:p>
     <o:p></o:p>
End Select <o:p></o:p>
End Function <o:p></o:p>
<o:p>

</o>
<o></o>
The code for addborders is the following :<o></o>
<o></o>

Sub addborders() <o:p></o:p>
 <o:p></o:p>
lastrowe = Worksheets("Documents Filiales").Cells(Rows.Count, "e").End(xlUp).Row <o:p></o:p>
Worksheets("Documents Filiales").Range("A1:l" & lastrowe).Select <o:p></o:p>
Selection.Borders(xlDiagonalDown).LineStyle = xlNone <o:p></o:p>
Selection.Borders(xlDiagonalUp).LineStyle = xlNone <o:p></o:p>
With Selection.Borders(xlEdgeLeft) <o:p></o:p>
    .LineStyle = xlContinuous <o:p></o:p>
    .ColorIndex = 0 <o:p></o:p>
    .TintAndShade = 0 <o:p></o:p>
    .Weight = xlThin <o:p></o:p>
End With <o:p></o:p>
With Selection.Borders(xlEdgeTop) <o:p></o:p>
    .LineStyle = xlContinuous <o:p></o:p>
    .ColorIndex = 0 <o:p></o:p>
    .TintAndShade = 0 <o:p></o:p>
    .Weight = xlThin <o:p></o:p>
End With <o:p></o:p>
With Selection.Borders(xlEdgeBottom) <o:p></o:p>
    .LineStyle = xlContinuous <o:p></o:p>
    .ColorIndex = 0 <o:p></o:p>
    .TintAndShade = 0 <o:p></o:p>
    .Weight = xlThin <o:p></o:p>
End With <o:p></o:p>
With Selection.Borders(xlEdgeRight) <o:p></o:p>
    .LineStyle = xlContinuous <o:p></o:p>
    .ColorIndex = 0 <o:p></o:p>
    .TintAndShade = 0 <o:p></o:p>
    .Weight = xlThin <o:p></o:p>
End With <o:p></o:p>
With Selection.Borders(xlInsideVertical) <o:p></o:p>
    .LineStyle = xlContinuous <o:p></o:p>
    .ColorIndex = 0 <o:p></o:p>
    .TintAndShade = 0 <o:p></o:p>
    .Weight = xlThin <o:p></o:p>
End With <o:p></o:p>
With Selection.Borders(xlInsideHorizontal) <o:p></o:p>
    .LineStyle = xlContinuous <o:p></o:p>
    .ColorIndex = 0 <o:p></o:p>
    .TintAndShade = 0 <o:p></o:p>
    .Weight = xlThin <o:p></o:p>
End With <o:p></o:p>
End Sub <o:p></o:p>
<o:p>

</o>
<o></o>
Hope you can help me with this one. Thank you very much for your time and help!

 

[nicnad]

Forgot the vlookups function code (created by jindon on ozgrid.com forum)

Function VLookUps(ByRef rng As Range, ByVal Criteria1 As String _
, ByVal refCol As Long, ParamArray a())
Dim r As Range, i As Long
With rng
For Each r In rng.Columns(1).Cells
If UCase(r.Value) = UCase(Criteria1) Then
If IsMissing(a) Then
VLookUps = VLookUps & "," & r(, refCol).Value
Else
For i = 0 To UBound(a) Step 2
If UCase(r(, a(i + 1)).Value) Like UCase(a(i)) Then
VLookUps = VLookUps & "," & r(, refCol).Value
End If
Next
End If
End If
Next
End With
If Len(VLookUps) Then
VLookUps = Mid$(VLookUps, 2)
Else
VLookUps = CVErr(xlErrNA)
End If
End Function

 

[Biz]

Forgot the vlookups function code (created by jindon on ozgrid.com forum)

Function VLookUps(ByRef rng As Range, ByVal Criteria1 As String _
, ByVal refCol As Long, ParamArray a())
Dim r As Range, i As Long
With rng
For Each r In rng.Columns(1).Cells
If UCase(r.Value) = UCase(Criteria1) Then
If IsMissing(a) Then
VLookUps = VLookUps & "," & r(, refCol).Value
Else
For i = 0 To UBound(a) Step 2
If UCase(r(, a(i + 1)).Value) Like UCase(a(i)) Then
VLookUps = VLookUps & "," & r(, refCol).Value
End If
Next
End If
End If
Next
End With
If Len(VLookUps) Then
VLookUps = Mid$(VLookUps, 2)
Else
VLookUps = CVErr(xlErrNA)
End If
End Function

Looks interesting.

Biz

 

[gregtx81]

Getting ready for bed, but I suspect I can help on the Worksheet_Change issue.

If you change more than one cell at once (e.g. via a paste) 'Target' in the Worksheet_Change procedure will be the range consisting of ALL of those simultaneously changed cells. When you write "If Target.Column = 5" only the single top-left most cell of Target is evaluated (and it appears in this case that it is not in Column E).

To evaluate whether ANY cell of the range 'Target' is in Column E use:

    If Not Intersect(Target, Columns(5)) Is Nothing Then        
        'code
    End If