Onnistuuko phaku vaihteluvälillä?

helpoin ja nopein tapa tehdä oma funktio...
moduuliin...


soluun kaava esim. =OmaPHaku(G1;A1:A100;5;2), missä

G1=hakuarvo

A1:A100= hakualue arvolle

5= vaihteluväli arvolle /-
jos eri positiivisilla ja negatiivisella , niin helppo fiksata kaavaan tarvittaessa

2=sarake
hakuarvo sarake on 1, joten arvo 2 palauttaa hakusarakkeen oikeanpuolella olevan sarakkeen arvot. Vastaavasti arvolla 0 palauttaisi vasemmanpuoleisen sarakkeen arvot

Function OmaPHaku(Haku As Double, Hakualue As Range, Vaihteluväli As Double, Sarake As Long)
Dim Solu As Range
Dim Tulos As String
xResult = ""
For Each Solu In Hakualue
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos = Tulos & Solu.Offset(0, Sarake - 1) & ", "
End If
Next
OmaPHaku = Left(Tulos, Len(Tulos) - 2)
End Function

Keep EXCELing
@Kunde

moduuliin...

Dim Tulos() As Double
Dim i As Integer
Dim Solu As Range

Sub OmaPHaku(Haku As Double, Hakualue As String, Vaihteluväli As Double, Sarake As Long)
i = 0
ReDim Tulos(0)
'tulos sarakkeeseen L
Range("L:L") = ""
For Each Solu In Range(Hakualue)
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos(i) = Solu.Offset(0, Sarake - 1)
i = i 1
ReDim Preserve Tulos(i)
End If
Next
Range("L1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
End Sub


'ko.taulukon moduuliin
'H1 = hakuarvo
'I1 = hakualue
'J1 =vaihteluväli
'K1 = sarake
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("H1:K1"), Target) Is Nothing Then
OmaPHaku Range("H1"), Range("I1"), Range("J1"), Range("K1")
End If
End Sub


Keep EXCELing
@Kunde

lisäsit koodin uuteen moduuliin...
ko taulukon moduuliin tarkoittaa sitä, että koodi lisätään sen taulukon moduuliin missä sen halutaan toimivan. Toki koodata voisin This Workbookiin kanssa, mutta sitten pitää tsekata , että koodi toimii vaan esim. Taul1:ssä eikä muissa. Mutta kätevää toisaalta, jos tarttee useammassa taulukossa samaa koodia....
eli jos jutut on Taul1:ssä niin kopioi alla oleva koodi siis sinne

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("H1:K1"), Target) Is Nothing Then
OmaPHaku Range("H1"), Range("I1"), Range("J1"), Range("K1")
End If
End Sub

Taul1 solut ja niiden merkitys on alla ja jos haluat muuttaa niin muutat koodissa
esim. soluissa tekstit
'H1 = hakuarvo =27,5
'I1 = hakualue =B1:B100
'J1 =vaihteluväli =5
'K1 = palautettava sarake =2 eli hakualueesta seuraava sarake oikealle tai voi hakea vasemmallekin 0 on eka sarake vasemmalle jne.

niin ja oisessa koodin pätkässä siis tulos sarakkeeseen L
muuta tarvittaessa

'tulos sarakkeeseen L
Range("L:L") = ""
...
...
...
Range("L1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)

Keep EXCELing
@Kunde

Et ole ymmärtänyt ohjeitani oikein ja olet sekoittanut nyt vanhaa ja uutta koodia keskenään...

Väännetään vielä rautalangasta, eli hakuarvo solussa C2 ja vaihteluväli solussa C1. Hakualue on A24:D600 ja haen sarakkeesta D eli arvolla 4, tällöin

Ensimmäinen koodini oli oma funktio ja jälkimmäinen podtaamani koodi ei ole oma funktio, vaan perustuu solujen muutokseen taulukossa. Eka näkyi, mutta jälkimmäisen ei näy funktiolistassa
2 eri versiota

versio1.
MODUULIIN....

Sub OmaPHaku(Haku As Double, Hakualue As Range, Vaihteluväli As Double, Sarake As Long)
i = 0
ReDim Tulos(0)
'tulos sarakkeeseen L
Range("B:B") = ""
For Each Solu In Hakualue
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos(i) = Solu.Offset(0, Sarake - 1)
i = i 1
ReDim Preserve Tulos(i)
End If
Next
Range("B1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
End Sub

SEN TAULUKON MODUULIIN MISSÄ TIEDOT ON ESIM TAUL1 MODUULIIN....
Taul1 solut ja niiden merkitys on alla ja jos haluat muuttaa niin muutat koodissa
esim. soluissa tekstit
'C1 = hakuarvo =27,5
'C2 = vaihteluväli=10
hakualue har codattu koodiin samoin kuin sarake

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Range("C1:C2"), Target) Is Nothing Then
OmaPHaku Range("C1"), Range("A24:D600"), Range("C2"), 4
End If
Application.EnableEvents = True
End Sub

versio 2
mitä tarjosin aluksi, siinä voi hakualueen ja sarakkeen kanssa syöttää soluihin

MODUULIIN...

Sub OmaPHaku(Haku As Double, Hakualue As String, Vaihteluväli As Double, Sarake As Long)
i = 0
ReDim Tulos(0)
'tulos sarakkeeseen L
Range("B:B") = ""
For Each Solu In Range(Hakualue)
If Solu >= Haku - (Vaihteluväli / 100) * Haku And Solu <= Haku (Vaihteluväli / 100) * Haku Then
Tulos(i) = Solu.Offset(0, Sarake - 1)
i = i 1
ReDim Preserve Tulos(i)
End If
Next
Range("B1").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
End Sub


SEN TAULUKON MODUULIIN MISSÄ TIEDOT ON ESIM TAUL1 MODUULIIN....
Taul1 solut ja niiden merkitys on alla ja jos haluat muuttaa niin muutat koodissa
esim. soluissa tekstit
'C1 = hakuarvo =27,5
'C2 = vaihteluväli=10
'C3= hakualue=A24:D600
'C4= sarake=4

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Range("C1:C4"), Target) Is Nothing Then
OmaPHaku Range("C1"), Range("C3"), Range("C2"), Range("C4")
End If
Application.EnableEvents = True
End Sub


Keep EXCELing
@Kunde