OBEB Bulan Excel Makro Kodu




Excel'de hücrelerimizdeki sayıların OBEB'ini bulmak için gerekli makro kodu aşağıdadır.

Çalıştırabilmek için Excel'de VBA sayfasında Insert modül ile modül ekleyip aşağıdaki kodları yapıştırmanız yeterlidir.


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 rak***** ininceye kadar a sütunundaki değerleri kalansız bölen i rak***** ulaşmaya çalış. Bulunamazsa en sonunda i=1 eşit olur ve 1 rak***** 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 rak***** 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 Sub

saol dostum