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.
Haasteellinen VBA koodi
8
769
Vastaukset
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 Subhipsaa 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 lieneeIlmoittaa " 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 Subarvaan, 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 FunctionLoistavaa 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
? 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ä.
Luetuimmat keskustelut
- 1592506
Kun viimeksi kohtasitte/näitte
Mitä olitte tekemässä? Millainen ympäristö oli? Löydetään toisemme...1361925Olet kyllä vaarallisen himokas
Luova, kaunis, määrätietoinen, pervo, mielenkiintoinen, kovanaama, naisellinen ja erikoinen.1061775- 781455
- 761388
Anna vielä vähän vihreää valoa
Teen sitten siirtoni, nainen. Tiedän, että olet jo varovaisesti yrittänyt lähestyä, mutta siitä on jo aikaa. Jos tunnet211357- 2281096
- 71890
Miksi homous puhuttaa konservatiiveja vuodesta toiseen?
Kysymykseen on vastattukin Kansanlähetyksen osalta: "Miksi sukupuoleen ja seksuaalisuuteen liittyvät asiat ovat konserv220880- 49831