OBEB Bulan Excel Makro Kodu

[ßyMesMes]

Türkiye'de ilk Mobil & PC Aynı Anda Metin2 Oyna. Triarchonline kalıcı ve uzun ömürlü yapısı ile 24 Temmuz'da açılıyor. | 1-99 Mobil Metin2 Triarch HEMEN TIKLA!

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 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 Sub

NOT: Bu çalışma kendi hazırladığım notlardan oluşmuştur.

 

[turkmmouser03]

Teşşekurler . Kaliteli Bir Konu Olmuş .

 

[Karcemackers]

Paylasım icin tesekkurler.

 

[ßyMesMes]

Rica ederim.

 

[umit99]

Eline sağlık.