Hakukaava hakusessa

muuta nimet ja solut sopivaksi
Nyt solusssa N1 kelpoisuusehto ja eläimet on soluissa Q1:QXXX ja kpl sarakeessa R.
Jos haluat makron toimivan automaattisesti lisää alla oleva jälkimmäinen koodi sitten ko.taulukon moduuliin

tavalliseen moduuliin...

Option Explicit
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim KäännettyAlue As Range
Dim KäännettyAlue2 As Range
Dim vika As Long
Dim Originaali As String
Dim a As Range
Dim b As Range
Dim i As Long
Dim solu As Range
Dim solu2 As Range
Dim EkaOsoite As String
Dim Alue2 As Variant
Dim Max As Collection
Function EtsiJaSiirrä(Hakuehto As Variant, Hakualue As Range) As Range
'muuta taulukon nimi sopivaksi
Worksheets("Data").Activate
With Range(Hakualue.Address)
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrä = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address <> EkaOsoite
End If
End With
End Function

Sub Testi2()
'muuta haettava eläin solu sopivaksi, nyt N1
Set Löydetty = EtsiJaSiirrä(Range("N1"), Range("C:C"))
KäännäAlue (Löydetty.Address)
End Sub

Public Sub KäännäAlue(Alue As String)
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'isonna aluetta tarvittaessa
Set a = Range("C1:C200").SpecialCells(xlCellTypeConstants)
Set b = Range(Alue)
Originaali = ActiveSheet.Name

Worksheets.Add.Name = "HuuHaa"
Range(a.Address).Value = 1
Range(b.Address).Clear

Sheets(Originaali).Select (False)
Cells.SpecialCells(xlCellTypeConstants).Select
Worksheets("HuuHaa").Delete
'muuta kpl-määrä sarake
Range("R1:R3") = 0
'muuta eläimet sarake
vika = Range("Q65536").End(xlUp).Row
For Each Alue2 In Selection.Areas
For Each solu In Range("Q1:Q" & vika)
Set Löydetty2 = EtsiJaSiirrä(solu, Alue2.Resize(, 10))
If Not Löydetty2 Is Nothing Then
solu.Offset(0, 1) = solu.Offset(0, 1) Löydetty2.Count
Else
solu.Offset(0, 1) = solu.Offset(0, 1) 0
End If
Next
Next
Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

ko. taulukon moduuliin...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'muuta haettava eläin solu sopivaksi, nyt N1
If Not Intersect(Range("N1"), Target) Is Nothing Then Testi2
End Sub


Keep EXCELing
@Kunde

Sepäs olikin mutkikkaampi kuin osasin kuvitella. Toimii. Suuret kiitokset.

Moi.
Minä olen pitkään yrittänyt rakentaa melkeinpä samanlaista, mutta vieläkin mutkikkaampaa systeemiä. Lähtötilanne eroaa tuosta eläin-esimerkistä siten, että minulla ei ole noita numeroita lopussa vaan pelkkiä tekstejä. Käytetään tässä nyt sitten tuota eläin-esimerkkiä mallina, niin ei tarvi koko kuvausta kirjoittaa. Osaan kyllä sitten ne solualueet sun muut muokata omaan juttuuni sopiviksi, jos tähän löytyisi koodia:
Voisiko tuon Kundepuun kirjoittaman koodin muokata siten, että se osaisi laskea tuosta ne "kissat" tai muut elukat joiden vasemmalla puolella ei ole sitä " papukaijaa" missään sarakkeessa. Muuten siis samanlainen, mutta jos oikein älysin, niin tuossa esimerkisik solun F4 "kissa" jätetään laskematta vain silloin, kun "papukaija" on solussa C4, ja minä haluaisin että se jää laskematta aina, kun papukaija on jossain soluista C4-E4. Toisin sanoen: kun kirjoittaisin tuossa sinne N1-soluun "papukaija", se laskisi vaikkapa "kissat" sellaisilta riveiltä, joilla ei lue lainkaan "papukaijaa" plus sellaisilta riveiltä, joilla on "kissa" ennen "papukaijaa", mutta ei sellaisia "kissoja", jotka ovat "papukaijan" jälkeen (eli oikealla puolella) samalla rivillä. Ja minäkin haluaisin tietää nimenomaan sen, että mitä eläintä tuolla ehdolla löytyisi eniten.

Mikä sulla alueena?
Samat C-L sarakkeet vai ?
Haetaan C-E sarakkeista sanaa vaiko C-L sarakkeista, jos löytyy niin ennen sitä olevat lasketaan tai jos ei hakusanaa ole rivillä, niin kaikki lasketaan?

Selitin tuon esimerkin näköjään epäselvästi, niin samapa tässä nyt kertoa kaikki numerotiedot, niin tulee sitten kerralla oikein:
hakualueeni on B1:K70. Sarakkeita tosiaan juuri se 10 kuten tuossa eka jutussakin, mutta rivejä vähän vähemmän. Eri vaihtoehtoja (eri "eläimiä") on 35 kpl. Tavoitteeni olisi hakea B:K, eli lasketaan, jos hakusanaa ei ole rivillä ja lasketaan, jos on ennen hakusanaa. Ei lasketa jos on hakusanan jälkeen. Minullakaan ei ole samalla rivillä samaa sanaa kahdesti, joten yhdeltä riviltä voi tulla vain 0 tai 1 ja kun rivejä on 70, kaikki lukemat tulevat olemaan välillä 0...70.

Option Explicit
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim KäännettyAlue As Range
Dim KäännettyAlue2 As Range
Dim Vika As Long
Dim Originaali As String
Dim a As Range
Dim b As Range
Dim i As Long
Dim solu As Range
Dim solu2 As Range
Dim EkaOsoite As String
Dim Alue2 As Variant
Dim Max As Collection
Function EtsiJaSiirrä(Hakuehto As Variant, Hakualue As Range) As Range
'muuta taulukon nimi sopivaksi
Worksheets("Data").Activate
With Range(Hakualue.Address)
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrä = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address <> EkaOsoite
End If
End With
End Function

Sub Testi2()
'muuta haettava eläin solu sopivaksi
Set Löydetty = EtsiJaSiirrä(Range("M1"), Range("B1:K100"))
KäännäAlue (Löydetty.Address)
End Sub
Sub LaajennaAlue()
Dim Rivi As Range
Dim Taulukko As Worksheet
Dim Vika As Long
Set Taulukko = ActiveSheet

For i = 1 To Taulukko.UsedRange.Rows.Count
Set Rivi = Taulukko.Rows(i)
If WorksheetFunction.CountA(Rivi) = 0 Then
Range("B" & i & ":K" & i).Value = 1
Else
Vika = Range("A" & i).End(xlToRight).Column
Range("B" & i, Cells(i, Vika)).Value = 1
End If
Next i
End Sub
Public Sub KäännäAlue(Alue As String)
Dim Solualue As Range
On Error Resume Next

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set a = Range("B1:K70").SpecialCells(xlCellTypeConstants)
Set b = Range(Alue)
Originaali = ActiveSheet.Name

Worksheets.Add.Name = "HuuHaa"
Range(a.Address).Clear
Range(b.Address).Value = 1
LaajennaAlue

Sheets(Originaali).Select (False)

Cells.SpecialCells(xlCellTypeConstants).Select
Worksheets("HuuHaa").Delete
'muuta tulos kpl-määrä sarake, nyt R-sarake
Range("Q1:Q10") = 0
'muuta eläimet sarake, nyt Q-sarake
Vika = Range("P65536").End(xlUp).row
For Each solu In Range("P1:P" & Vika)
Set Löydetty2 = Nothing
Set Löydetty2 = EtsiJaSiirrä(solu, Selection)
If Not Löydetty2 Is Nothing Then
solu.Offset(0, 1) = solu.Offset(0, 1) Löydetty2.Count
Else
solu.Offset(0, 1) = solu.Offset(0, 1) 0
End If
Next
Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Hienoa, kiitos.