OBEB Bulan Excel Makro Kodu

Excel'de hücrelerimizdeki sayıların OBEB'ini bulmak için gerekli makro kodunu bu derste görebilirsiniz.

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.
  • Etiketler;
Yorum Yaz

Yorum yazabilmek için üye girişi yapmanız gerekiyor!

Yukarı Git