Keskustelu: Ohjelmointikysymykset: VBA: Excel kyssäri

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