obeb
Tarih
22/05/2012 23:30
Konu Sahibi
accessman
Yorumlar
1
Okunma
816
Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 5
  • 4
  • 3
  • 2
  • 1

Derecelendirme: 0/5 - 0 oy



accessman

Kullanici Avatari
Onursal
2.367
31/10/2008
425
Denizli
Ofis 2003
20/09/2016,00:20
Çözüldü 

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
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


bunu bir Excel dosyasına ekleyip örnek haline getirebilirmisiniz
ben yapamadım
teşekkürler
@benbendedeilem
Cevapla


accessman

Kullanici Avatari
Onursal
2.367
31/10/2008
425
Denizli
Ofis 2003
20/09/2016,00:20
Çözüldü 

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub GCDx()

Dim Max             As Integer
Dim x               As Integer
Dim GCD             As Integer
Dim GCDTemp         As Integer
Dim Cell            As Object
Dim Rng             As String

    Rng = "A1:D1"
    Max = Application.WorksheetFunction.Max(Range(Rng))
    For x = 1 To Int(Max / 2) + 1
        For Each Cell In Range(Rng)
            If Cell.Value Mod x = 0 Then
                GCDTemp = x
                Else
                GCDTemp = 0
                Exit For
            End If
        Next
        GCD = Application.WorksheetFunction.Max(GCD, GCDTemp)
    Next
    MsgBox (GCD)

End Sub

@benbendedeilem
Cevapla







Konuyu Okuyanlar: 1 Ziyaretçi



Türkçe Çeviri: MCTR, Forum Yazılımı: MyBB, © 2002-2016 MyBB Group.
DMCA.com Protection Status
© Desing by XSTYLED| Develops by ozanakkaya