Check first five characters and replace offset

[kelseyvdh]

Hi everybody, I've a VBA macro which works, but I want a small change and I can't figure out how to solve it.



The code, as shown below, compares the value in one sheet ("Offer2400HPIN") with the value in another sheet ("Offerte"). Then it replaces the value in Offset 11 with the value from the other sheet.



This works great, but I want to make it so it will only compare the first five characters in the cells. This is because of the fact that the value after the first five characters may differ.



So, for example: If Sheets("Offerte").Range("E14").Value = ABCDEF it must also replace the value in offset 11 if the value in Sheets("Offer2400HPIN").Range("C21") = ABCDEG



You guys have any idea? Many thanks in advance!

Sub quoteUploaden()
On Error Resume Next
    Dim Found As Range
    Dim lRow As Long
    Dim WS As Worksheet
    Dim slctCell As Range
    Dim FirstRow As Long
    Dim FirstRowQuote As Long
    
    Set WS = ThisWorkbook.Worksheets("Offer2400HPIN")
    With ActiveSheet
    FirstRow = Sheets("Offerte").Range("E158").End(xlUp).Row
    FirstRowQuote = WS.Range("C21").End(xlDown).Row
        For lRow = 14 To FirstRow
            Set Found = Find_All(.Cells(lRow, "E"), WS.Range("C" & 21 & ":" & "D" & FirstRowQuote), , xlWhole)
            If Found Is Nothing Then
            .Cells(lRow, "P").Interior.Color = vbWhite
            Else
                .Cells(lRow, "P").Interior.Color = vbGreen
                .Cells(lRow, "P") = Found.Offset(0, 11)
                Sheets("Offerte").Range("P14:P158").Replace What:=" €", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            End If
        Next lRow
    End With
End Sub

[offthelip]

use the left function around the string you asre trying to find e.g:

left(.Cells(lRow, "E"),5)

[kelseyvdh]

Thank you for your help, but I cannot seem to make it work. When I put it like this, it will give an error:

Sub quoteUploaden()
On Error Resume Next
    Dim Found As Range
    Dim lRow As Long
    Dim WS As Worksheet
    Dim slctCell As Range
    Dim FirstRow As Long
    Dim FirstRowQuote As Long
    
    Set WS = ThisWorkbook.Worksheets("Offer2400HPIN")
    With ActiveSheet
    FirstRow = Sheets("Offerte").Range("E158").End(xlUp).Row
    FirstRowQuote = WS.Range("C21").End(xlDown).Row
        For lRow = 14 To FirstRow
            Set Found = Left(.Cells(lRow, "E"), 5), WS.Range("C" & 21 & ":" & "D" & FirstRowQuote), , xlWhole)
            If Found Is Nothing Then
            .Cells(lRow, "P").Interior.Color = vbWhite
            Else
                .Cells(lRow, "P").Interior.Color = vbGreen
                .Cells(lRow, "P") = Found.Offset(0, 11)
                Sheets("Offerte").Range("P14:P158").Replace What:=" €", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            End If
        Next lRow
    End With
End Sub

[offthelip]

your syntax for hte find staement is wrong try this:

Set Found = WS.Range("C" & 21 & ":" & "D" & FirstRowQuote).find(Left(.Cells(lRow, "E"), 5), , , xlpart)

[kelseyvdh]

Works great! Thank you so much!