Kod:
Sub obeb()
---- Örneğin OBEB'ini bulacağımız sayıları Excel hücrelerimizde A sütununda alt alta yazalım. Arada boş bırakılan hücre olmasın. A sütununda yazdığımız rakamlardan başka bir şey yazılı olmasın. ---
---- Değişkenleri tanımlayalım. ---
Dim uzunluk, min
Dim yön As Boolean
---- A sütununda 65000'inci satıra kadar olan hücrelerden yukarıdan aşağıya inildiğinde en aşağıdaki son dolu hücrenin kaçıncı satırda olduğunu bulalım. ---
uzunluk = [a65000].End(3).Row
---- Eğer rakamların yazılacağı A sütununda 2'den az sayıda hücrede rakam varsa OBEB veya OKEK hesaplamaya gerek kalmaz. Durum öyle ise "exit sub" yap, yani bu programcığı burada kapat, çalışmasını durdur yani. ---
If uzunluk < 2 Then Exit Sub
---- A sütunundaki rakamlardan en küçüğünü min değişkenine ata, çünkü OBEB hesabında en küçük değer bize lazım olacak---
min = WorksheetFunction.min(Range("A1:A" & uzunluk))
---- Döngüye gir. i değişkenini min değerinden 1'e kadar birer birer azalt.---
For i = min To 1 Step -1
yön = False
For j = 1 To uzunluk
DoEvents
---- a sütunundaki rakamların hepsini i değerine böl. Eğer kalansız bölünüyorsa i değeri obeb değeridir.---
If Cells(j, 1) Mod i 0 Then
---- a sütunundaki rakamlardan tek bir tanesi bile i değerine tam bölünemiyorsa döngüden çık
i değerini bir azalt, tekrar a sütunundaki tüm değerleri yeni i değerine böl. hepsi kalansız bölünüyorsa obeb yeni i değeridir. Aralarında tam bölünemeyen varsa yine döngüden çık.
i değerini yine 1 azalt. Tekrar a sütunundaki tüm değerleri yeni i değerine böl. a sütunundaki tüm sayıların kalansız bölüneceği i değerine ulaşıncaya kadar işlem böyle devam etsin.
i değeri 1 rakamına ininceye kadar a sütunundaki değerleri kalansız bölen i rakamına ulaşmaya çalış. Bulunamazsa en sonunda i=1 eşit olur ve 1 rakamına tüm değerler kalansız bölüneceği için obeb 1 olur.---
yön = True
Exit For
End If
Next
---- a sütunundaki tüm değerlerin i rakamına tam bölündüğünde yön=false olur ve döngüden tamamen çıkılır, çünkü aranan şartlara uyan değer artık elde edilmiştir.---
If yön = False Then
Exit For
End If
Next
---- şimdi emeğimizin karşılığını alma zamanı, bulduğumuz sonuçları hücrelere yazdırarak veya msgbox ile bildirerek, gereken yerlerde kullanırız.---
Range("A1:A" & uzunluk).Select
Cells(1, 2) = "Obeb ="
Cells(1, 2).Font.Bold = True
Cells(1, 3) = i
MsgBox "OBEB = " & i
End Subbunu bir Excel dosyasına ekleyip örnek haline getirebilirmisiniz
ben yapamadım
teşekkürler
