Macro til lookup

Du er velkommen til at sende arket (mailadr. under profil).

- og så velkommen til...

Hejsa

Uden at have nogle reele data at teste på og uden at have testet, så kan du jo se om denne virker på en test fil.

Hvis ikke der er overkrift i kolonne G, så skal TRUE i 3. linie ændres til FALSE


Sub Eksperten_899309()
    ' Konsanter
    Const bCOLUMN_G_HAS_HEADER As Boolean = True
    Const iCOL_COMPARE As Integer = 7 'G
    Const iCOL_DATE_TO As Integer = 11 'K
    Const iCOL_DATE_FROM As Integer = 13 'M
    ' Variabler
    Dim wsOne As Worksheet
    Dim wsTwo As Worksheet
    Dim lRowOne As Long
    Dim lRowTwo As Long
    Dim lRowStart As Long
    Dim bFound As Boolean
   
    ' Tildel værdier til variabler
    Set wsOne = Worksheets("Ark1")
    Set wsTwo = Worksheets("Ark2")
   
    ' Start række
    lRowStart = 1
    If bCOLUMN_G_HAS_HEADER Then lRowStart = 2
   
    ' Løb igennem Ark 1
    For lRowOne = lRowStart To wsOne.Range("A1").CurrentRegion.Rows.Count
   
        ' Løb igennem Ark 2
        For lRowTwo = lRowStart To wsTwo.Range("A1").CurrentRegion.Rows.Count
           
            If wsOne.Cells(lRowOne, iCOL_COMPARE).Value = wsTwo.Cells(lRowTwo, iCOL_COMPARE).Value Then
                ' Værdi fundet
                bFound = True
                Exit For
            End If
           
        Next lRowTwo
   
        ' Skriv i Ark 1
        If bFound Then
            ' Match fundet
            If CLng(wsTwo.Cells(lRowTwo, iCOL_DATE_FROM).Value) = 1 Then
                ' Datoværdi 1 = 01-01-1900 00:00
                wsOne.Cells(lRowOne, iCOL_DATE_TO).Value = "Ukendt"
            Else
                wsOne.Cells(lRowOne, iCOL_DATE_TO).Value = "OK"
            End If
        Else
            ' Ingen match fundet
            wsOne.Cells(lRowOne, iCOL_DATE_TO).Value = "Prod."
        End If
       
    Next lRowOne
   
End Sub

Har lige prøvet en enkelt gang, men får udfyldt alle felter i kolonne K  med "Ukendt"

Jeg skal nok også have arket i hænderne for at tilpasse det sidste - mail på profil eller under kontakt på hjemmeside.

Makro justeret til - svar :-)