Onnistuuko phaku vaihteluvälillä?

Monimutkaista

Olen yrittänyt löytää ratkaisua phaku-funktioon kun hakuarvona on vaihteluväli. Kirjoitan funktiot englanniksi kun en tunne suomenkielisiä vastineita.

Jos hakuarvo on solussa A2 arvona 27,5 ja haluan hakea vlookup-funktiolla kaikki tulokset jotka ovat esimerkiksi 5%/-5% hakuarvosta eli vaihteluvälillä 26,13-28,88. Miten funktion saisi ymmärtämään vaihteluvälin lähdeaineistosta ja vielä siten että solun A2 arvoa voi muuttaa? Tarvitaanko tähän index match funktioita tai joitain muita?

8

679

Äänestä

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • kunde

      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

      • Monimutkaista

        Wow, tämä toimii! Erittäin iso käsi täältä, olet selvästi Excel ammattilainen. Tuo vba on hiukan vieras maailma itselle, täytyy vielä ajatuksella käydä läpi mitä tuossa tapahtuu.

        Mitä moduulissa pitäisi muuttaa, jotta jokainen hakutulos olisi omassa solussa vertikaalisesti?

    • Kundepuu

      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

      • Monimutkaista

        Nyt putosin tai en saa pelittämään.
        En oikein ymmärrä mitä näillä tarkoitat tai voi olla että teen väärin jossain muualla:

        '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

        Lisään siis uuteen moduulin mutta en ymmärrä viittauksia noihin yksittäisiin soluihin.

    • 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.

    • kunde

      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

      • Monimutkaista

        Ongelma 1.
        Jos moduulissa;
        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

        OmaPHaku-funktio löytyy hienosti valikosta ja toimii. Kun laitan 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

        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

        Ei tunnista koko OmaPhaku-funktiota, eikä löydy funktion lisäys valikosta.

        Ongelma 2.
        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:

        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)
        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("B").Resize(UBound(Tulos)).Value = Application.WorksheetFunction.Transpose(Tulos)
        End Sub
        Private Sub Worksheet_Change(ByVal Target As Range)
        If Not Intersect(Range("C2:4"), Target) Is Nothing Then
        OmaPHaku Range("C2"), Range("A24:D600"), Range("C1"), Range("4")
        End If
        End Sub

        Eli tulossarake on B ja kaavassa hakuarvo ja vaihteluväli korvattu soluilla C1 & C2 ja hakualue määritelty.

        Kiitos jos viitsit vielä avustaa, voi kyllä olla että joudun luovuttamaan tämän kanssa kun osaaminen ei riitä vba:n puolella.

    • 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

    Ketjusta on poistettu 0 sääntöjenvastaista viestiä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Ikävöin sinua kokoyön!

      En halua odottaa, että voisin näyttää sinulle kuinka paljon rakastan sinua. Toivon, että uskot, että olen varsin hullun
      Ikävä
      45
      3151

    2. Kova karman laki

      Karman lain kautta pahantekijä tehdessään pahaa toteuttaa koston ja rangaistuksen sille jolle pahaa on tehty. Tämä tarko
      Hindulaisuus
      508
      1927

    3. Päivieni piristys, missä olet?

      Toit iloa ja valoa mun elämään ☀️ Nyt mennyt kohta viikko ettei ole nähty. Kaipaan nähdä sua silti ja pelkään vaikka tei
      Ikävä
      17
      1900

    4. Näen jatkuvasti Sompasaunalla alastomia miehiä ja naisia

      jotka menevät siihen viereiseen rantaan myös uimaan alasti. Sompasaunat on siis Mustikkamaalla Helsingissä, ja kuljen si
      Maailman menoa
      79
      1712

    5. Älä mahdollisesti ota itseesi

      En voinut tietää. Sitäpaitsi.. niin
      Ikävä
      18
      1512

    6. Jos sinä olisit pyrkimässä elämääni takaisin

      Arvelisin sen johtuvan siitä, että olisit taas polttanut jonkun sillan takanasi. Ei taida löytyä enää kyliltä naista, jo
      Tunteet
      43
      1388

    7. Ota nainen yhteyttä ja tee Tikusta asiaa?

      Niin sitten minä teen Takusta asiaa.
      Ikävä
      26
      1322

    8. Millainen kaivattusi luonne on?

      Millaisia luonteenpiirteitä arvostat kaivatussa? Oletteko samanlaisia luonteeltanne?
      Ikävä
      90
      1319

    9. Helena ja Mikko Koivun ero jatkuu edelleen ja loppua ei näy.

      Voi eikä, miksi menee noin vaikeaksi avioero ja sopua ei tää ex- pari vaan saa.
      Kotimaiset julkkisjuorut
      116
      1167

    10. UPM suunnittelee paperintuotannon lopettamista LPR:ssa

      Ilta-Sanomissa oli uutinen. Metsäyhtiö UPM suunnittelee paperintuotannon lopettamista Kaukaan-tehtaalla Lappeenrannassa
      Lappeenranta
      111
      1135
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt