Hycke kirjoitti:
Tuon haun voisi toteuttaa oheista koodia(ei juurikaan testattu) muokkaamalla:
Sub Hakua() hakusana = "pekka" For Each S In ActiveWorkbook.Sheets 'käydään läpi jokainen välilehti If S.Name <> "Haku" Then ' ei kuitenkaan haku lehdykkää i = 3 'määritellään ensimmäinen hakurivi Do Until S.Cells(i, "A").Value = "" 'loopataan joka rivi kunnes A-sarake on tyhjä j = 1 'määritellään ensimmäinen hakusarake Do Until S.Cells(i, j).Value = "" If InStr(1, S.Cells(i, j).Value, hakusana) > 0 Then 'verrataan hakusanaan 'jos löytyi niin kopioidaan haku lehdelle KopioiRiviHakuun S.Name, i Exit Do End If j = j + 1 Loop i = i + 1 Loop End If Next End Sub Sub KopioiRiviHakuun(S As String, ByVal Rivi As Long) hakui = 10 'hakutulokset alkavat riviltä 10 Do Until Sheets("haku").Cells(hakui, "A").Value = "" 'etsitään ensimmäinen tyhjärivi haku lehdeltä hakui = hakui + 1 Loop 'kopioidaan tiedot annetusta sheetistä ja rivistä sar = 1 'kopioidaan alkaen sarakkeesta 1 Do Until Sheets(S).Cells(Rivi, sar).Value = "" Sheets("haku").Cells(hakui, sar).Value = Sheets(S).Cells(Rivi, sar).Value sar = sar + 1 Loop End Sub
Koodi on lainattu vanhasta aiheesta johon ei voinut vastata.
Kun haen jotain kyseisellä koodin pätkällä, niin haku jättää osan löytämättä.
Esim. Excel taulukossa josta koitan hakea on 8000 riviä tietoa ja tietoa jota koitan hakea on 1388 riviä, joista haku löytää 1004 riviä.
Mitäs koodissa tarvitsisi muuttaa jotta haku löytäisi kaikki rivit?
Entäs millä saan laitettua haun että se hakee vain "O" sarakkeesta ettei haku hae kaikilta sarakkeilta?
Moikka Maccy!
vaikkapa näin...
Private Sub CommandButton1_Click()
Dim taulu, solu
Application.ScreenUpdating = False
For Each taulu In Sheets
i = 1: j = j + 1
If taulu.Name <> "Taul3" Then 'esim.
Sheets("Taul3").Cells(1, j).Value = taulu.Name
'esim. haku alkaa O-sarkkeen toiselta riviltä
For Each solu In taulu.Range("O2:O" + _
CStr(taulu.Cells.SpecialCells(xlCellTypeLastCell).Row))
If solu.Value >= 50 And solu.Value <= 100 Then '.esim
i = i + 1
Sheets("Taul3").Cells(i, j).Value = solu.Value
End If
Next
End If
Next
Application.ScreenUpdating = True
End SubMoro Nea!
Mihin tuossa määritellään hakusana?
Ja kun koitin tota koodia, niin se toi taulukkojen nimet taulukkoon joka on määritelty koodissa. Esim taulukkojen nimet on taul1, taul2, taul3 -> Taul3:een tulee A1: taul1, B1: taul2, C1: taul3.
Moikka taas Maccy!
esimerkin hakukriteeri on tämä rivi:
If solu.Value >= 50 And solu.Value <= 100 Then '.esim
Elikä jos jonkin solun arvo on suurempi tai yhtäsuuri kuin 50 ja solun arvo on pienempi tai yhtäsuuri kuin 100. Tietoa etsitään joka taulukosta paitsi taulukosta "Taul3" ja mikäli hakuehto täyttyy, tiedot listataan taulukkoon "Taul3" edellyttäen, että aktiivisesta työkirjasta löytyy taulukko nimeltä "Taul3". Listaus menee tyyliin "Taul1" tiedot sarakkeeseen A jne..
Jos haluat esim. hakea tiedot soluista, joissa lukee sana Matti niin muutta em. rivin koodiksi...
If solu.Value = "Matti" Then
Jos haluat esim. hakea tiedot soluista, joissa lukee sana Matti tai Teppo niin muutta samaisen rivin koodiksi...
If solu.Value = "Matti" Or solu.Value = "Teppo" Then
Noniin nyt alkoi haku toimimaan. Vielä olisi silti yksi kysymys: Onko mahdollista saada kopioitua kaikki rivit mistä haku löytää Matteja?
Esim. Hakusana: Matti
Taulukko josta haetaan: A B C D 1 Matti Kuusisto Havutie 2 Puumala 2 Teppo Jokinen Jokikuja 3 Oulu 3 Matti Tuominen Pääkatu 1 Helsinki 4 Matti Koivu Hiekkatie 1 Espoo Taulukko johon haku toisi tiedot: A B C D 1 Matti Kuusisto Havutie 2 Puumala 2 Matti Tuominen Pääkatu 1 Helsinki 3 Matti Koivu Hiekkatie 1 Espoo
Moikka taas Maccy!
mahdollista on ja aivan käsittämättömän helppoa, tarvitsee vain käyttää copy/paste -kombinaatiota...
Private Sub CommandButton1_Click()
Dim taulu, solu
Application.ScreenUpdating = False
Sheets("Taul3").Range("A1:" + Sheets("Taul3"). _
Cells.SpecialCells(xlCellTypeLastCell).Address).Select
Selection.Clear
For Each taulu In Sheets
If taulu.Name <> "Taul3" Then
For Each solu In taulu.Range("A1:A" + _
CStr(taulu.Cells.SpecialCells(xlCellTypeLastCell).Row))
If solu.Value = "Matti" Then
i = i + 1
taulu.Range("A" + CStr(solu.Row) + ":D" + _
CStr(solu.Row)).Copy Destination:=Sheets( _
"Taul3").Range("A" + CStr(i) + ":D" + CStr(i))
End If
Next
End If
Next
Application.ScreenUpdating = True
End Subneau33 kirjoitti:
Moikka taas Maccy!
mahdollista on ja aivan käsittämättömän helppoa, tarvitsee vain käyttää copy/paste -kombinaatiota...
Ei se ny kaikille oo helppoa, mut kiitos avusta Nea.
Nyt tuli taas yksi kysymys ja luultavasti hieman hankalampi.. eli miten sais kyseisen taulukon toteutettua
esim1. a b c 1 Matti Saapas 221287-1234 2 Teppo Koivunen 100185-1342 3 Matti Saapas 131182-4321 4 Teppo Mänty 290290-3421 Pitäisi tulla suunnilleen tälläinen a b c d e 1 Matti 221287-1234 Saapas 131182-4321 Saapas 2 Teppo 100185-1342 Koivunen 290290-3421 Mänty esim2. a b c 1 123 A 2 321 B 3 321 C 4 123 D Pitäisi tulla suunnilleen tälläinen a b c 1 123 A D 2 321 B C
Tätä ei jaksais käsin tehdä, koska tietoa löytyy paljon.
Eli haku etsii "a" sarakkeelta vaikka kaikki samat "arvot" ja kopio saman "arvon" tiedot samalle riville. mm. jokaisen "Matti" nimisen tiedot tulee samalle riville "Matti 221287-1234 Saapas 131182-4321 Saapas".
Heippa taas Maccy!
vaikkapa jotenkin näin...
Dim tiedot() As String
Dim taulu
Private Sub CommandButton1_Click()
ReDim tiedot(1, 1)
Sheets("Taul3").Range("A1:" + Sheets("Taul3"). _
Cells.SpecialCells(xlCellTypeLastCell).Address).Select
Selection.Clear
etsiSarake1
yhdistäTiedot
vieTauluun
End Sub
Sub etsiSarake1()
Dim exists As Boolean
For Each taulu In Sheets
If taulu.Name <> "Taul3" Then
For i = 1 To taulu.Cells.SpecialCells(xlCellTypeLastCell).Row
exists = False
For j = 1 To UBound(tiedot, 2)
If tiedot(0, j) = taulu.Cells(i, 1).Value Then
exists = True: Exit For
End If
Next j
If Not exists Then
k = k + 1
ReDim Preserve tiedot(1, k)
tiedot(0, k) = taulu.Cells(i, 1).Value
End If
Next i
End If
Next
End Sub
Sub yhdistäTiedot()
For Each taulu In Sheets
If taulu.Name <> "Taul3" Then
For i = 1 To UBound(tiedot, 2)
For j = 1 To taulu.Cells.SpecialCells(xlCellTypeLastCell).Row
If taulu.Cells(j, 1).Value = tiedot(0, i) Then
tiedot(1, i) = tiedot(1, i) _
& taulu.Cells(j, 3).Value + ";" _
& taulu.Cells(j, 2).Value + ";"
End If
Next j
Next i
End If
Next
End Sub
Sub vieTauluun()
For i = 1 To UBound(tiedot, 2) - 1
Dim tiedotStr As String, splitti() As String
tiedotStr = tiedot(0, i) & ";" & tiedot(1, i)
tiedotStr = Left(tiedotStr, Len(tiedotStr) - 1)
splitti = Split(tiedotStr, ";")
For j = 1 To 5
Sheets("Taul3").Cells(i, j).Value = splitti(j - 1)
Next j
Next i
Erase tiedot, splitti
End Sub...jaksatko copy/paste'ttaa tämän käsin?
Kiitos Nea! Toimii mainiosti toi koodi. Mutta olisi todennäköisesti helppo kysymys: Miten saan että se hakee lajitettaviksi menevät tiedot vaikka "haku" taulukosta (ettei hae kaikista kuten tuossa koodissa) ja lajittelisi ne sinne "taul3" taulukkoon.
Heippa taas Maccy!
Nyt voit alkaa tutkimaan jutskia ihan omin voimin mikäli mielenkiintoa riittää. Ja jos riittää niin käytä mahdollisimman paljon VBA-Helppiä + nettiä apuna. The Linkki
Perehdy muuttujiin ja siihen mitä kaikkea voi saada aikaan esim. näissä hakuviritelmissä käyttämällä objektimuuttujia. Toinen tutkimisen arvoinen asia on tehdä hakuja täysin päinvastaisella tavalla, eli piilottamalla taulu(i)sta kaikki sellainen tieto, joka on hakuehtojen ulkopuolella...Itse suosin tätä piilottamistapaa...
Hyvää kevään jatkoa & antoisia hetkiä Excel/VBA:n parissa...
Itse tein haun näin viimeksi:
Private Sub haku() Dim vali As Integer vali = 0 ' tällä subilla haku ajetaan Dim arTemp() As String '´temp array Dim bFound As Boolean 'Flag Dim i1 As Integer 'taulukon laskuri '(mitäsanaahaetaan,mistähaetaan,"miltä alueelta",arraynimi) bFound = FindAll(ComboBox2.Text, Sheet3, "A:C", arTemp()) If bFound = True Then Sheet2.Columns.Delete Sheet2.Rows.Delete For i1 = 1 To UBound(arTemp) vali = vali + 1 Sheet2.Visible = True Sheet2.Select 'ja tulosten näyttäminen esimerkkinä: Sheet2.Cells(1, 1) = "Nimi" Sheet2.Cells(1, 2) = "Missä" Sheet2.Cells(1, 3) = "Mitä tapahtui" Sheet2.Cells(1, 8) = "Aika" Sheet2.Cells(vali, 1) = Sheet3.Cells(arTemp(i1), 1) Sheet2.Cells(vali, 2) = Sheet3.Cells(arTemp(i1), 2) Sheet2.Cells(vali, 3) = Sheet3.Cells(arTemp(i1), 3) Sheet2.Cells(vali, 8) = Sheet3.Cells(arTemp(i1), 5) Next i1 'jos haluat hakea että jos tämän kolumnin tämä solu on tämä,niin etsi tältä kyseiseltä riviltä tämä - metodilla, pistä tähän väliin uudestaan bfound = FindAll(mitäsanaahaetaan,mistähaetaan,"miltä alueelta",arraynimi) ja hae siltä sivulta minne tulokset aiemmin kirjottui. Else MsgBox "Hakua ei löydy" End If End Sub 'Tässä alla valmis funktio Function FindAll(ByVal sText As String, ByRef oSht As Worksheet, ByRef sRange As String, ByRef arMatches() As String) As Boolean ' -------------------------------------------------------------------------------------------------------------- ' FindAll - To find all instances of the1 given string and return the row numbers. ' If there are not any matches the function will return false ' -------------------------------------------------------------------------------------------------------------- On Error GoTo Err_Trap Dim rFnd As Range ' Range Object Dim iArr As Integer ' Counter for Array Dim rFirstAddress ' Address of the First Find ' ----------------- ' Clear the Array ' ----------------- Erase arMatches Set rFnd = oSht.Range(sRange).Find(What:=sText, LookIn:=xlValues, LookAt:=xlPart) If Not rFnd Is Nothing Then rFirstAddress = rFnd.Address Do Until rFnd Is Nothing iArr = iArr + 1 ReDim Preserve arMatches(iArr) arMatches(iArr) = rFnd.Row ' rFnd.Row ' Store the Row where the text is found Set rFnd = oSht.Range(sRange).FindNext(rFnd) If rFnd.Address = rFirstAddress Then Exit Do ' Do not allow wrapped search Loop FindAll = True Else ' ---------------------- ' No Value is Found ' ---------------------- FindAll = False End If ' ----------------------- ' Error Handling ' ----------------------- Err_Trap: If Err <> 0 Then MsgBox Err.Number & " " & Err.Description, vbInformation, "Find All" Err.Clear FindAll = False Exit Function End If End Function
Aihe on jo aika vanha, joten et voi enää vastata siihen.