Haasteellinen VBA koodi

Avuton SEARCH

Yritän etsiä verkkoasemalla olevasta kansiosta vastaavuuksia.

Siis kansiossa on noin 500 tiedostoa(xls), tiedotoissa on Taul1:llä erilaista tietoa erilaisissa soluissa. Hakemani tieto on sarakkeessa L välillä L2:L50.

Haluan etsiä kolmea eri tietoa, esim "Osa1" ja "osa 2" ja "osa 3", nämä kaikki pitäisi löytyä samasta tiedostosta ja näin saisin tulokseksi yksi tai kuinka monta sellaista tiedosta nyt löytyykään missä kaikki kyseiset arvot ovat olemassa.

Windowssin search toiminnollahan voi näitä kaivella, mutta se ei anna tulokseksi kuin ikkunan missä tiedostot näkyvät, jotka sisältä vät yhden tiedon....

Voiko siis saada koodilla sellaisen listauksen missä näkyy vastaavuuksien määrä? Joskun vastaavuuksia voisi etsi vain kahdella arvolla ja joskus taas kolmella.

8

826

Äänestä

    Vastaukset 8

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • kunde

      nyt hakee Osa1, Osa2 ja Osa3 - muuta koodissa nimet ja jos haluat etsiä kahta ehtoa niin hipsaa rivi
      If laskuri = 3 Then
      ja poista hipsu riviltä
      ' If laskuri = 3 Or laskuri = 2 Then
      muuta polku sopivaksi .LookIn = "C:\Kokeilu"

      moduuliin...

      Sub Hae()
      Dim i As Integer
      Dim wb As Workbook
      Dim laskuri As Integer
      On Error Resume Next
      Application.ScreenUpdating = False
      Range("A:A") = ""

      With Application.FileSearch
      .NewSearch
      .LookIn = "C:\Kokeilu"
      .SearchSubFolders = False
      .Filename = "*.xls"
      .Execute
      For i = 1 To .FoundFiles.Count
      laskuri = 0
      Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
      If Not Etsi("Osa1") Is Nothing Then
      laskuri = laskuri 1
      End If
      If Not Etsi("Osa2") Is Nothing Then
      laskuri = laskuri 1
      End If
      If Not Etsi("Osa3") Is Nothing Then
      laskuri = laskuri 1
      End If
      wb.Close
      If laskuri = 3 Then
      ' If laskuri = 3 Or laskuri = 2 Then
      Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
      End If

      Next i
      End With
      Application.ScreenUpdating = True
      End Sub


      Function Etsi(Hakuehto As Variant) As Range
      Dim solu As Range
      Dim EkaOsoite As String
      Worksheets("Taul1").Activate
      With Range("L2:L50")
      Set solu = .Find( _
      What:=Hakuehto, _
      LookIn:=xlValues, _
      LookAt:=xlWhole, _
      SearchOrder:=xlByRows, _
      SearchDirection:=xlNext, _
      MatchCase:=False, _
      SearchFormat:=False)
      If Not solu Is Nothing Then
      Set Etsi = solu
      End If
      End With

      End Function

      Keep Excelling
      @Kunde

      • äimän käki

        Miten me pärjättiin ennekuin meillä oli @Kunde?

      • Avuton SEARCHH

        Kiitokset hyvästä koodinpätkästä. En kuitenkaan onnistut asiassa. En ymmärrä miksi ei hae tietoa, vaikka kokeilin sekä kahta että kolmea hakua.

        Moduulissa ei näy virheitä, joten koodi kyllä sinänsä kunnossa, en vain osaa lukemalla tulkita mikä vialla.

        Sub deeyksDirectory()

        'tässä kansiossa olevat tiedot eivät täsmää muiden kanssa, alkaa G28 solusta etteenpäin.

        Alla yksi hakujuttu minkä joskus löysin....

        Dim Path As String
        Dim FileName As String
        Dim tWB As Workbook
        Dim tWS As Worksheet
        Dim mWB As Workbook
        Dim aWS As Worksheet
        Dim RowCount As Long
        Dim uRange As Range


        Path = "I:\Ohjeet\Keko-ohjeet exel\Vaihe D01\" 'Vaihda tähän oikea sheetti numero

        Application.EnableEvents = False
        Set mWB = Workbooks.Add(1)
        Set aWS = mWB.ActiveSheet
        If Right(Path, 1) Application.PathSeparator Then
        Path = Path & Application.PathSeparator
        End If
        FileName = Dir(Path & "*.xls", vbNormal)
        Do Until FileName = ""
        Set tWB = Workbooks.Open(FileName:=Path & FileName)
        For Each tWS In tWB.Worksheets
        Set uRange = tWS.Range("g28", tWS.Cells(tWS.UsedRange.Row tWS.UsedRange.Rows _
        .Count - 1, tWS.UsedRange.Column tWS.UsedRange.Columns.Count - 1))
        If RowCount uRange.Rows.Count > 65536 Then
        aWS.Columns.AutoFit
        Set aWS = mWB.Sheets.Add(After:=aWS)
        RowCount = 0
        End If
        If RowCount = 0 Then
        aWS.Range("G28", aWS.Cells(1, uRange.Columns.Count)).Value = _
        tWS.Range("G28", tWS.Cells(1, uRange.Columns.Count)).Value
        RowCount = 1
        End If
        aWS.Range("A" & RowCount 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
        = uRange.Value
        RowCount = RowCount uRange.Rows.Count
        Next
        tWB.Close False
        FileName = Dir()
        Loop
        aWS.Columns.AutoFit
        mWB.Sheets(1).Select
        Application.EnableEvents = True
        End Sub

      • kundepuu
        Avuton SEARCHH kirjoitti:

        Kiitokset hyvästä koodinpätkästä. En kuitenkaan onnistut asiassa. En ymmärrä miksi ei hae tietoa, vaikka kokeilin sekä kahta että kolmea hakua.

        Moduulissa ei näy virheitä, joten koodi kyllä sinänsä kunnossa, en vain osaa lukemalla tulkita mikä vialla.

        Sub deeyksDirectory()

        'tässä kansiossa olevat tiedot eivät täsmää muiden kanssa, alkaa G28 solusta etteenpäin.

        Alla yksi hakujuttu minkä joskus löysin....

        Dim Path As String
        Dim FileName As String
        Dim tWB As Workbook
        Dim tWS As Worksheet
        Dim mWB As Workbook
        Dim aWS As Worksheet
        Dim RowCount As Long
        Dim uRange As Range


        Path = "I:\Ohjeet\Keko-ohjeet exel\Vaihe D01\" 'Vaihda tähän oikea sheetti numero

        Application.EnableEvents = False
        Set mWB = Workbooks.Add(1)
        Set aWS = mWB.ActiveSheet
        If Right(Path, 1) Application.PathSeparator Then
        Path = Path & Application.PathSeparator
        End If
        FileName = Dir(Path & "*.xls", vbNormal)
        Do Until FileName = ""
        Set tWB = Workbooks.Open(FileName:=Path & FileName)
        For Each tWS In tWB.Worksheets
        Set uRange = tWS.Range("g28", tWS.Cells(tWS.UsedRange.Row tWS.UsedRange.Rows _
        .Count - 1, tWS.UsedRange.Column tWS.UsedRange.Columns.Count - 1))
        If RowCount uRange.Rows.Count > 65536 Then
        aWS.Columns.AutoFit
        Set aWS = mWB.Sheets.Add(After:=aWS)
        RowCount = 0
        End If
        If RowCount = 0 Then
        aWS.Range("G28", aWS.Cells(1, uRange.Columns.Count)).Value = _
        tWS.Range("G28", tWS.Cells(1, uRange.Columns.Count)).Value
        RowCount = 1
        End If
        aWS.Range("A" & RowCount 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
        = uRange.Value
        RowCount = RowCount uRange.Rows.Count
        Next
        tWB.Close False
        FileName = Dir()
        Loop
        aWS.Columns.AutoFit
        mWB.Sheets(1).Select
        Application.EnableEvents = True
        End Sub

        hipsaa koodissa seuraava rivi ja testaa tuleeko virheilmoitusta, jos tulee niin mika?
        On Error Resume Next

        P.S. olen taasen yllapidon bannissa ja en pysty vastaamaan kuin naista internet kahviloista.
        Kiitos bannista yllapito, vois ainakin syyn ilmoittaa- liikaa vastattu lienee

      • Haasteeton
        kundepuu kirjoitti:

        hipsaa koodissa seuraava rivi ja testaa tuleeko virheilmoitusta, jos tulee niin mika?
        On Error Resume Next

        P.S. olen taasen yllapidon bannissa ja en pysty vastaamaan kuin naista internet kahviloista.
        Kiitos bannista yllapito, vois ainakin syyn ilmoittaa- liikaa vastattu lienee

        Ilmoittaa " run-time error"445" -> object doesn´t support this action.

        Debug jää kohtaan -> With Application.FileSearch

        Alla vielä koodi, näkyy mitä muutin. En ymmärtänyt noita haku arvoja, koitin siis laittaa "osa1" tilalle haettavan tiedon? Aluksi laitoin ne sheet 1:lle soluun a1 ja a2. Koodi putsasi ne sieltä pois...

        Sub Hae()
        Dim i As Integer
        Dim wb As Workbook
        Dim laskuri As Integer
        'On Error Resume Next
        Application.ScreenUpdating = False
        Range("A:A") = ""

        With Application.FileSearch
        .NewSearch
        .LookIn = "I:\Ohjeet\Keko-ohjeet exel\Vaihe E07"
        .SearchSubFolders = False
        .Filename = "*.xls"
        .Execute
        For i = 1 To .FoundFiles.Count
        laskuri = 0
        Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
        If Not Etsi("836766123") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("598359850") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("Osa3") Is Nothing Then
        laskuri = laskuri 1
        End If
        wb.Close
        'If laskuri = 3 Then
        If laskuri = 3 Or laskuri = 2 Then
        Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
        End If

        Next i
        End With
        Application.ScreenUpdating = True
        End Sub

      • Kundepuu alias Kunde
        Haasteeton kirjoitti:

        Ilmoittaa " run-time error"445" -> object doesn´t support this action.

        Debug jää kohtaan -> With Application.FileSearch

        Alla vielä koodi, näkyy mitä muutin. En ymmärtänyt noita haku arvoja, koitin siis laittaa "osa1" tilalle haettavan tiedon? Aluksi laitoin ne sheet 1:lle soluun a1 ja a2. Koodi putsasi ne sieltä pois...

        Sub Hae()
        Dim i As Integer
        Dim wb As Workbook
        Dim laskuri As Integer
        'On Error Resume Next
        Application.ScreenUpdating = False
        Range("A:A") = ""

        With Application.FileSearch
        .NewSearch
        .LookIn = "I:\Ohjeet\Keko-ohjeet exel\Vaihe E07"
        .SearchSubFolders = False
        .Filename = "*.xls"
        .Execute
        For i = 1 To .FoundFiles.Count
        laskuri = 0
        Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
        If Not Etsi("836766123") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("598359850") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("Osa3") Is Nothing Then
        laskuri = laskuri 1
        End If
        wb.Close
        'If laskuri = 3 Then
        If laskuri = 3 Or laskuri = 2 Then
        Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
        End If

        Next i
        End With
        Application.ScreenUpdating = True
        End Sub

        arvaan, luulen tietavani -TIEDAN
        kaytossssi on siis EXCEL 2007...
        siinapa onkin poistettu tuo filesearch objekti ...
        joten muutettuna esim...

        Option Explicit
        Dim wb As Workbook
        Dim polku As String
        Dim nimi As Variant
        Dim laskuri As Integer
        Public ty๖kirja As String
        Sub a()
        'On Error Resume Next
        Application.ScreenUpdating = False
        Range("A:A") = ""
        polku = "C:\Kokeilu\"
        nimi = Dir(polku)
        Do While nimi ""
        Set wb = Workbooks.Open(Filename:=polku & nimi)
        ty๖kirja = nimi
        laskuri = 0
        If Not Etsi("Osa1") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("Osa2") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("Osa3") Is Nothing Then
        laskuri = laskuri 1
        End If
        wb.Close
        'If laskuri = 3 Then
        If laskuri = 3 Or laskuri = 2 Then
        Range("A65536").End(xlUp).Offset(1, 0) = polku & nimi
        End If
        nimi = Dir
        Loop
        Application.ScreenUpdating = True
        End Sub
        Function Etsi(Hakuehto As Variant) As Range
        Dim solu As Range
        Dim EkaOsoite As String

        Workbooks(ty๖kirja).Activate
        Workbooks(ty๖kirja).Worksheets("Taul1").Activate
        With Range("L2:L50")
        Set solu = .Find( _
        What:=Hakuehto, _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False, _
        SearchFormat:=False)
        If Not solu Is Nothing Then
        Set Etsi = solu
        End If
        End With

        End Function

      • EIvaan osaa
        Kundepuu alias Kunde kirjoitti:

        arvaan, luulen tietavani -TIEDAN
        kaytossssi on siis EXCEL 2007...
        siinapa onkin poistettu tuo filesearch objekti ...
        joten muutettuna esim...

        Option Explicit
        Dim wb As Workbook
        Dim polku As String
        Dim nimi As Variant
        Dim laskuri As Integer
        Public ty๖kirja As String
        Sub a()
        'On Error Resume Next
        Application.ScreenUpdating = False
        Range("A:A") = ""
        polku = "C:\Kokeilu\"
        nimi = Dir(polku)
        Do While nimi ""
        Set wb = Workbooks.Open(Filename:=polku & nimi)
        ty๖kirja = nimi
        laskuri = 0
        If Not Etsi("Osa1") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("Osa2") Is Nothing Then
        laskuri = laskuri 1
        End If
        If Not Etsi("Osa3") Is Nothing Then
        laskuri = laskuri 1
        End If
        wb.Close
        'If laskuri = 3 Then
        If laskuri = 3 Or laskuri = 2 Then
        Range("A65536").End(xlUp).Offset(1, 0) = polku & nimi
        End If
        nimi = Dir
        Loop
        Application.ScreenUpdating = True
        End Sub
        Function Etsi(Hakuehto As Variant) As Range
        Dim solu As Range
        Dim EkaOsoite As String

        Workbooks(ty๖kirja).Activate
        Workbooks(ty๖kirja).Worksheets("Taul1").Activate
        With Range("L2:L50")
        Set solu = .Find( _
        What:=Hakuehto, _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False, _
        SearchFormat:=False)
        If Not solu Is Nothing Then
        Set Etsi = solu
        End If
        End With

        End Function

        Loistavaa työskentelyä kunde.

        Suuret kiitokset.

        Jos vielä yksi pikku juttu. Voiko tämän osa1 "If Not Etsi("Osa1") Is Nothing Then" kohdan saada esim. activesheet cellvalueksi jotenkin "If Not Etsi("activesheet.Cellvalue.Taul1!B1") Is Nothing Then
        ?

      • kunde
        EIvaan osaa kirjoitti:

        Loistavaa työskentelyä kunde.

        Suuret kiitokset.

        Jos vielä yksi pikku juttu. Voiko tämän osa1 "If Not Etsi("Osa1") Is Nothing Then" kohdan saada esim. activesheet cellvalueksi jotenkin "If Not Etsi("activesheet.Cellvalue.Taul1!B1") Is Nothing Then
        ?

        If Not Etsi(Range("B1")) Is Nothing ...

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

    Takaisin ylös

    Luetuimmat keskustelut

    1. Mikä on totta mikä ei?

      Onko juoru vai ei että nimeltä mainitsematon henkilö on tehnyt naiselle/naisille jotain joka on väärin?
      Kuhmo
      23
      1385

    2. Viesti sinulle

      Tiedät että tunteet ja ajatukset ja meillä on vahva yhteys mistä molemmat tiedetään. Odotan sinua ☀️
      Ikävä
      62
      1190

    3. Olen kironnut sinut alimpaan helvettiin

      Hyvää matkaa.
      Ikävä
      95
      958

    4. Mitä sinulle on tapahtunut lapsena

      Kun olet noin sairas päästäsi? Pikkupojalle ( Miehen kehossa)
      Ikävä
      105
      914

    5. Haluan purkaa vielä tuntemuksia

      Tykkään sinusta kovin paljon❤️ olen surullinen tilanteestasi ja siitä mitä me olemme yhdessä joutuneet kokemaan. Tämä ei
      Ikävä
      21
      777

    6. Persujen Puhoksen retki

      Perussuomalaiset olivat tehneet turistibussimatkan Puhokseen. Tosin raukat olivat niin peloissaan, etteivät uskaltaneet
      Perussuomalaiset
      279
      775

    7. Lopetetaanko tämä

      Juttu ja mennään eteenpäin? Pystytkö?
      Ikävä
      120
      715

    8. Tunteiden käsittely kertoo ihmisestä.

      Kun puhutaan "tavallisesta" ihmisestä, joka on suht tasapainoinen eläjä, niin puhutaan oikeastaan taitavasta tunteiden k
      Sinkut
      210
      689

    9. Kyllä tiedän sun

      Likaiset pelit selän takana
      Ikävä
      62
      668

    10. Onko tuo joku katkera nainen oikeasti

      Joka sinua syyttää?
      Ikävä
      100
      616

    11. Jopa poliisi nauraa paskaista pelkuripersuille

      Puhoksessa jäi "isänmaantoivot" bussiin vapisemaan :-D https://www.is.fi/politiikka/art-2000012319632.html
      Maailman menoa
      289
      579

    12. Ketkä käy potkimassa ovia öisin?

      Enää ei naurata.
      Haapavesi
      13
      544

    13. Just saying

      Mies joka antaa naiselle turvallisen olon, on seksikäs. Ei kieroja kikkoja ja haluaa olla vain sen yhden naisen mies.
      Ikävä
      104
      528

    14. Pilkettä sunnuntain silmässä

      😉 Jos tästä ketjusta löytyisi yksi ihminen, joka saisi sut hymyilemään tänään… Millainen hän olisi? Ei tarvitse kerto
      Sinkut
      73
      481

    15. Onko muka 21 vuoden ikäero paljon?

      🤔
      Rakkaus ja rakastaminen
      34
      465

    16. Tehdään yhdessä itsestämme

      Parhaat versiot❤️ Se vaatii molemmilta hyvää itsetuntoa!
      Ikävä
      39
      464

    17. Voisin antaa sulle nyt

      Halin❤️
      Ikävä
      47
      450

    18. Päivän aivopieru Trumpilta

      Trump julisti sodan hyttysiä vastaan. Myös punkit ovat Trumpin sodan kohteena. Eikö vieläkään USA:n kansa tajua tuon uko
      Maailman menoa
      46
      437

    19. Oliko Jani Halmeen aika jo tippua TTK:sta?

      Jani Halme ja Claudia Ketonen joutuivat jättämään TTK:n. Halme ja Ketonen saivat viimeiseksi jäänestä tanssista, sambas
      Tanssii tähtien kanssa
      23
      437

    20. Aika on tuonut järkeä

      Sä et tiedä musta kaikkea. Jos tietäisit, ymmärtäisit, miksi me ei sovita yhteen. Öljy ja vesi. En mä ole valehdellut,
      Järki ja tunteet
      42
      423
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt