Haasteellinen VBA koodi

Avuton SEARCH

2010-09-17 11:19:46

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.

810

Äänestä

Vastaukset

kunde
2010-09-17 15:37:32
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
  2010-09-17 20:49:23
  Miten me pärjättiin ennekuin meillä oli @Kunde?
- Avuton SEARCHH
  2010-09-20 13:28:23
  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
  2010-09-23 07:59:48
  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
  2010-09-24 11:34:24
  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
  2010-09-25 07:57:50
  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
  2010-09-27 06:25:37
  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
  2010-09-27 11:07:50
  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

Riikka Purran kaudella nousi bensan hinta yli 2 euron
Muistatteko kuinka edellisen vasemmistohallituksen aikana, ns. Marinin aikakaudella, bensiiniä sai 1,3 euron litrahinnal
09.03.2026 17:52Maailman menoa
163
5015
Veli Sofia teki urosmehiläisen työn
Paljastaessaan kuinka TPS:ssä ei joukkuehenki toimi sooloilijoiden vuoksi, jonka takia koko seura ei pärjää kilpailussa
10.03.2026 19:32Maailman menoa
20
3611
Mitäs nyt sijoittajat?
Pörssit laskevat maailmalla Iranin sodan takia ja muutenkin ovat olleet Trumpin vallan alla epävarmat. Ainoa, mikä on no
09.03.2026 11:16Maailman menoa
164
3426
Hjallis Harkimon, 72, Jasmine-rakas, 37, paljastaa suhteen alusta: "Vähän..."
Liikemies, kansanedustaja Hjallis Harkimo ja tuottaja-juontaja Jasmine Pajari ovat pariskunta. He asuvat yhdessä Sipooss
09.03.2026 09:35Suomalaiset julkkikset
38
2927
Unisex-vessat
Ahdistaa. Miksi kaikki pitää tasapäistää tasa-arvon nimissä? Tasa-arvo on sitä, että kunnioitetaan sukupuolien erilaisu
10.03.2026 06:47Tunteet
108
2689
Sosiaalidemokratia romahtanut kautta maailman
nuoret eivät enää kannata järjetöntä aatetta, joten demarien täytyy hakea kannattajia mamuista. Ruotsin sos.demit jo kie
11.03.2026 10:02Maailman menoa
28
2058
Jutta Larm, 52, haluaa kumota tämän piintyneen ikämyytin
Oletko samaa mieltä? Jutta Larm on 52-vuotias ja tehnyt pitkän uran yrittäjänä. Hän haluaa kumota tämän piintyneen ikämy
09.03.2026 09:4550 plus
19
1905
Jäit kiinni siitä
että katselet minua. Käänsin pääni, minäkin etsin sinua, ja meidän katseemme kohtasivat. Eikä se haittaa - molemmat ky
09.03.2026 20:52Ikävä
12
1824
Vastuun ottaminen omasta hyvinvoinnista
Olen huomannut tuttavapiirissäni ihmisiä, joilla on mt-diagnooseja. Sen sijaan, että millekään asialle yritettäisiin teh
10.03.2026 01:03Henkinen hyvinvointi ja mielenterveys
155
1522
Henri Alen tilittää yllättäen Vappu Pimiän uudesta MasterChef -pestistä: "Vaikka hän ei..."
Vappu Pimiä on uusi MasterChef Suomi -tuomari. Hän liittyi uudella MasterChef Suomi -kaudella arvovaltaiseen tuomaristoo
09.03.2026 09:38Suomalaiset julkkikset
11
1512

Haasteellinen VBA koodi

Vastaukset

Avuton SEARCHH kirjoitti:

kundepuu kirjoitti:

Haasteeton kirjoitti:

Kundepuu alias Kunde kirjoitti:

EIvaan osaa kirjoitti:

Luetuimmat keskustelut

Riikka Purran kaudella nousi bensan hinta yli 2 euron

Veli Sofia teki urosmehiläisen työn

Mitäs nyt sijoittajat?

Hjallis Harkimon, 72, Jasmine-rakas, 37, paljastaa suhteen alusta: "Vähän..."

Unisex-vessat

Sosiaalidemokratia romahtanut kautta maailman

Jutta Larm, 52, haluaa kumota tämän piintyneen ikämyytin

Jäit kiinni siitä

Vastuun ottaminen omasta hyvinvoinnista

Henri Alen tilittää yllättäen Vappu Pimiän uudesta MasterChef -pestistä: "Vaikka hän ei..."

Tykkäisitkö tällaisesta mökistä? Anni Ihamäki sai tv:ssä massiivisen remontin kesämökille

Katsotko Yle Areenasta sarjoja? Nämä ulkomaiset sarjat alkavat maaliskuussa