VBA - vlookup (eller tilsvarende) uden stop og med sum

Tillæg:

Summen er betinget af, at der i J15:AA15 er en celle med fyldefarve "sort". I det nye ark med sum skal der listes fra A3 og ned, hvilket ark forekomsten (altså teksten) er fundet i. Er fylde farve "sort" også fundet i J15:AA15 i et ark, skal dette retuneres som et "x" i C3 og ned. Altså ud for arknavnet så jeg får en liste.

Kan godt skrive VBA-koden - hvis du sender en lille model af din fil - f.eks. med 3 ark - således at ark 4 anvendes til opsummering.

Søgekriteriet indtastes i inputbox.

Spørgsmål: Kan søgning fortsætte til næste ark, hvis blot en forkomst er fundet?

@-adresse under min profil.

Hej Peter.

Du har fået en mail. :-)

Hej Karsten det har du også - her er koden i version 1:

Rem Version 1
Rem =========
Const sortCI = 1                                    'Interior.ColorIndex
Const OversigtsArkNavn = "Oversigt_sort"
Dim antalArk As Integer, osArk As Worksheet, osRæk As Integer
Public Sub søgEfterSort()
Dim søgeord As String

    antalArk = ActiveWorkbook.Sheets.Count
   
    If erOversigtsArkOpbygget = False Then
        opbygOversigtsArk
        osRæk = 3
    Else
        osRæk = findAntalRæk(OversigtsArkNavn)
        If osRæk < 3 Then
            osRæk = 3
        End If
    End If

Rem oversigtark - selvstændigt object
    Set osArk = ActiveWorkbook.Sheets(OversigtsArkNavn)
   
    søgeord = InputBox("Indtast søgeord", "SøgEfterSort")
   
    If søgeord <> "" Then
        Application.ScreenUpdating = False
        udførSøgning søgeord
       
        osArk.Activate
        osArk.Columns.AutoFit
        Application.ScreenUpdating = True
    End If
End Sub
Private Function erOversigtsArkOpbygget()
Dim ark As Worksheet
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name = OversigtsArkNavn Then
            erOversigtsArkOpbygget = True
            Exit Function
        End If
    Next
   
    erOversigtsArkOpbygget = False
End Function
Private Sub opbygOversigtsArk()
    With ActiveWorkbook
        .Sheets.Add After:=.Sheets(.Sheets.Count)
        .Sheets(antalArk + 1).Name = OversigtsArkNavn
    End With
End Sub
Private Sub udførSøgning(søgeord)
Dim ark As Worksheet, soFundet As Integer, fafundet As Boolean
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name <> OversigtsArkNavn Then
            ark.Select
            soFundet = findesSøgeord(søgeord)
            If soFundet > 0 Then
                fafundet = findesFarven(ark)
                opdaterOversigt søgeord, ark.Name, fafundet
            End If
        End If
    Next
End Sub
Private Function findesSøgeord(søgeord)
    With ActiveSheet.Range("A1:IV65000")
        Set c = .Find(søgeord, LookIn:=xlValues, LookAt:=xlPart)    'xlWhole
        If Not c Is Nothing Then
            findesSøgeord = c.Row
        Else
            findesSøgeord = 0
        End If
    End With
End Function
Private Function findesFarven(ark As Worksheet)
Dim cc As Object
    For Each cc In ark.Range("H15:AB16").Cells
        If cc.Interior.ColorIndex = sortCI Then
            findesFarven = True
            Exit Function
        End If
    Next cc
   
    findesFarven = False
End Function
Private Sub opdaterOversigt(søgeord, arknavn, fafundet As Boolean)
    With osArk
        .Range("A" & CStr(osRæk)) = søgeord
        .Range("B" & CStr(osRæk)) = arknavn
       
        If fafundet = True Then
            .Range("C" & CStr(osRæk)) = "x"
        End If
       
        osRæk = osRæk + 1
       
    End With
End Sub
Private Function findAntalRæk(arknavn)
Dim ræk As Long
    ActiveWorkbook.Sheets(arknavn).Select
   
    For ræk = 3 To 65000
        If Cells(ræk, 1) = "" Then
            findAntalRæk = ræk
            Exit Function
        End If
    Next ræk
    Stop
End Function

Svaret i mail. For andre som måtte være interesseret, så kommer det endelige resultat her.

Peter, det ser ret fint ud - dog lige et på rettelser.

Tak

Selv tak..