Function....End Function yardımı

[ECYavuz]

Değerli Arkadaşlar... Aşağıda yer alan Data dosyasında bilgi arama döngüsünü Function .... End Function olarak nasıl düzenleyebiliriz. Yardımcı olacak arkadaşlara şimdiden Şükran..

'Sabit değerler
Q6 = TextBox1.Value
ecy = TextBox2.Value
BL = TextBox3.Value

'Değişken Değerler
alt = 0
ust = 0
A1 = 0
A2 = 0
S8 = 0: S9 = 0: S10 = 0: S11 = 0: S12 = 0: S13 = 0


'Döngünün yapıldığı kod bölümü (Bu bölümü Function...End Function şeklinde düzenlemek istiyorum.)

With Data.Range("C" & Q6 & ":C" & ecy)
Set s = .Find(BL, LookIn:=xlValues)
If Not s Is Nothing Then
firstaddress = s.Address
End If
Do
On Error Resume Next
SS = s.Address(RowAbsolute:=False, ColumnAbsolute:=False)
SS = Right(SS, Len(SS) - 1)
ad = Data.Range("C" & SS).Value
If Left(ad, Len(BL)) = BL Then
If Data.Range("V" & SS).Value = "1" Then
S8 = S8 + 1
ElseIf Data.Range("V" & SS).Value = "2" Then
S9 = S9 + 1
ElseIf Data.Range("V" & SS).Value = "0" Then
S10 = S10 + 1
End If
End If
If Right(ad, Len(BL)) = BL Then
If Data.Range("V" & SS).Value = "1" Then
S11 = S11 + 1
ElseIf Data.Range("V" & SS).Value = "2" Then
S12 = S12 + 1
ElseIf Data.Range("V" & SS).Value = "0" Then
S13 = S13 + 1
End If
End If
If Data.Range("W" & SS).Value <> "" Or Data.Range("W" & SS).Value <> Empty Then
If Left(Data.Range("W" & SS).Value, 1) <> " " Then A1 = CInt(Left(Data.Range("W" & SS).Value, 1))
If Right(Data.Range("W" & SS).Value, 1) <> " " Then A2 = CInt(Right(Data.Range("W" & SS).Value, 1))
If A1 + A2 <= 2 Then
alt = alt + 1
End If
If A1 + A2 > 2 Then
ust = ust + 1
End If
End If
Set s = .FindNext(s)
Loop While Not s Is Nothing And s.Address <> firstaddress
If alt + ust > 0 Then Alt1.Value = CInt(alt / (alt + ust) * 100)
If alt + ust > 0 Then Ust1.Value = CInt(ust / (alt + ust) * 100)
End With

Çıktılar alt, ust, S8, S9, S10, S11, S12, S13, olacak lütfen.

 

[ECYavuz]

&#304;nan&#305;lmaz ama ger&#231;ek oldu... Bu konuda yard&#305;mc&#305; olcak kimse yokmu?

 

[ECYavuz]

Bu konuya el atacak kimse yok mu?

Çok zor bişi mi sordum, Function...End Function konusunda bilgi sahibi kimse yokmu? Var tabii de ilgilenen yok mu?

 

[ECYavuz]

Yard&#305;mc&#305; olacak kimse &#231;&#305;kmad&#305; ama yine de te&#351;ekk&#252;rler...

 

[Zeki Gürsoy]

Deneyin.

Function [B]FONKSIYON[/B](Q6, ecy, BL) As Integer
'Sabit değerler
'Q6 = TextBox1.Value
'ecy = TextBox2.Value
'BL = TextBox3.Value
 
'Değişken Değerler
alt = 0
ust = 0
A1 = 0
A2 = 0
S8 = 0: S9 = 0: S10 = 0: S11 = 0: S12 = 0: S13 = 0
 
'Döngünün yapıldığı kod bölümü (Bu bölümü Function...End Function şeklinde düzenlemek istiyorum.)
 
On Error Resume Next
 
With Data.Range("C" & Q6 & ":C" & ecy)
    Set s = .Find(BL, LookIn:=xlValues)
 
    If Not s Is Nothing Then
        firstaddress = s.Address
    End If
 
    Do
        SS = s.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        SS = Right(SS, Len(SS) - 1)
        ad = Data.Range("C" & SS).Value
 
        If Left(ad, Len(BL)) = BL Then
            If Data.Range("V" & SS).Value = "1" Then
                S8 = S8 + 1
            ElseIf Data.Range("V" & SS).Value = "2" Then
                S9 = S9 + 1
            ElseIf Data.Range("V" & SS).Value = "0" Then
                S10 = S10 + 1
            End If
        End If
 
        If Right(ad, Len(BL)) = BL Then
            If Data.Range("V" & SS).Value = "1" Then
                S11 = S11 + 1
            ElseIf Data.Range("V" & SS).Value = "2" Then
                S12 = S12 + 1
            ElseIf Data.Range("V" & SS).Value = "0" Then
                S13 = S13 + 1
            End If
        End If
 
        If Data.Range("W" & SS).Value <> "" Or _
                    Data.Range("W" & SS).Value <> Empty Then
            If Left(Data.Range("W" & SS).Value, 1) <> " " Then _
                    A1 = CInt(Left(Data.Range("W" & SS).Value, 1))
            If Right(Data.Range("W" & SS).Value, 1) <> " " Then _
                    A2 = CInt(Right(Data.Range("W" & SS).Value, 1))
            If A1 + A2 <= 2 Then
                alt = alt + 1
            End If
 
            If A1 + A2 > 2 Then
            ust = ust + 1
            End If
 
        End If
 
        Set s = .FindNext(s)
 
    Loop While Not s Is Nothing And s.Address <> firstaddress
 
    If alt + ust > 0 Then [B]FONKSIYON[/B] = CInt(alt / (alt + ust) * 100)
    If alt + ust > 0 Then [B]FONKSIYON[/B] = CInt(ust / (alt + ust) * 100)
 
End With
 
End Function

 

[ECYavuz]

Say&#305;n Anemos te&#351;ekk&#252;rler,

Mant&#305;&#287;&#305; anlad&#305;m. Yard&#305;mc&#305; oldunuz.