- Katılım
- 5 Ocak 2014
- Mesajlar
- 3,333
- Tepkime puanı
- 6
- Puanları
- 136
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.
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, minDim 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 çıki 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 ForEnd IfNext---- ş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) = iMsgBox "OBEB = " & iEnd Sub
NOT: Bu çalışma kendi hazırladığım notlardan oluşmuştur.
Ç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.
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, minDim 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 çıki 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 ForEnd IfNext---- ş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) = iMsgBox "OBEB = " & iEnd Sub
NOT: Bu çalışma kendi hazırladığım notlardan oluşmuştur.
