• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

şarta bağlı macro ile sayı üretme

O

onurcan1979

Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
Merhaba arkadaşlar ben şarta bağlı macro ile sayı üretmek istiyorum örnek ekte mevcutur. anlatmak istedim d hücresinde aynı isme sahip olan lar kendi aralarında yısı ilerlesin ay boyunca kaçtane aynı olduğu önemli değil önemli olan sayıları gün içinde aynı rakam olmasın bu konuda yardımcı olabilirseniz çok sevinirim şimdiden teşekkürler
 

Ekli dosyalar

Sizlerinde yeni yılınız kutlu olsun.
Mesajınız çözüm bulana kadar her daim üstlerde kalsın. :)
 
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAYI_ÜRET()
    Dim X As Integer, Say As Integer, Sayı As Integer
    Dim Y As Integer, Z As Byte, İlk As Integer
    
    Application.ScreenUpdating = False
    
    Range("E2:AI" & Rows.Count).ClearContents
    
    For X = 2 To Cells(Rows.Count, 4).End(3).Row
        Say = WorksheetFunction.CountIf(Range("D:D"), Cells(X, 4))
        Select Case Say
            Case 1
                Range("E" & X & ":AI" & X) = 1
            Case Is > 1
                İlk = Range("D:D").Find(Cells(X, 4), , , xlWhole).Row
                For Y = 5 To 35
10                  Randomize Timer()
                    Sayı = Int(Rnd() * Say) + 1
                    If WorksheetFunction.CountIf(Range(Cells(İlk, Y), Cells(İlk + Say - 1, Y)), Sayı) > 0 Then GoTo 10
                    For Z = X To X + Say - 1
                        If Cells(Z, Y) = "" Then
                            Cells(Z, Y) = Sayı
                            Exit For
                        Else
                            Exit For
                        End If
                    Next
                Next
        End Select
    Next
        
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAYI_ÜRET()
    Dim X As Integer, Say As Integer, Sayı As Integer
    Dim Y As Integer, Z As Byte, İlk As Integer
    
    Application.ScreenUpdating = False
    
    Range("E2:AI" & Rows.Count).ClearContents
    
    For X = 2 To Cells(Rows.Count, 4).End(3).Row
        Say = WorksheetFunction.CountIf(Range("D:D"), Cells(X, 4))
        Select Case Say
            Case 1
                Range("E" & X & ":AI" & X) = 1
            Case Is > 1
                İlk = Range("D:D").Find(Cells(X, 4), , , xlWhole).Row
                For Y = 5 To 35
10                  Randomize Timer()
                    Sayı = Int(Rnd() * Say) + 1
                    If WorksheetFunction.CountIf(Range(Cells(İlk, Y), Cells(İlk + Say - 1, Y)), Sayı) > 0 Then GoTo 10
                    For Z = X To X + Say - 1
                        If Cells(Z, Y) = "" Then
                            Cells(Z, Y) = Sayı
                            Exit For
                        Else
                            Exit For
                        End If
                    Next
                Next
        End Select
    Next
        
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

emeğinize sağlık çok güzel olmuş fakat ufak bir sorun daha var yan yana ilerleyişler düzenli olacak mesela 7 tane genel var bunlar birincisi 1-2-3-4-5-6-7-1-2-3-4-5-6-7-1-2-3-4-5-6-7 gibi gidecek
ikinci sıradaki ise 2-3-4-5-6-7-1-2-3-4-5-6-7 gibi gidecek eğer sayı hem düzenli ilerleyecek hemde aynı gün içinde aynı sayılar denk gelmiyecek gibi bunu ayarlaya bilirmiyiz
 
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAYI_ÜRET()
    Dim X1 As Integer, X2 As Integer, X3 As Byte
    Dim Say As Integer, Sayı As Integer, İlk As Integer
    
    Application.ScreenUpdating = False
    
    Range("E2:AI" & Rows.Count).ClearContents
    Sayı = 1
    
    For X1 = 2 To Cells(Rows.Count, 4).End(3).Row
        Say = WorksheetFunction.CountIf(Range("D:D"), Cells(X1, 4))
        Select Case Say
            Case 1
                Range("E" & X1 & ":AI" & X1) = 1
            Case Is > 1
                İlk = Range("D:D").Find(Cells(X1, 4), , , xlWhole).Row
                If Cells(İlk, "E") <> "" Then GoTo Devam
                For X2 = X1 To X1 + Say - 1
                    For X3 = 5 To 35
                        Cells(X2, X3) = Sayı
                        Sayı = Sayı + 1
                        If Sayı > Say Then Sayı = 1
                    Next
                Next
        End Select
Devam:
    Next
        
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAYI_ÜRET()
    Dim X1 As Integer, X2 As Integer, X3 As Byte
    Dim Say As Integer, Sayı As Integer, İlk As Integer
    
    Application.ScreenUpdating = False
    
    Range("E2:AI" & Rows.Count).ClearContents
    Sayı = 1
    
    For X1 = 2 To Cells(Rows.Count, 4).End(3).Row
        Say = WorksheetFunction.CountIf(Range("D:D"), Cells(X1, 4))
        Select Case Say
            Case 1
                Range("E" & X1 & ":AI" & X1) = 1
            Case Is > 1
                İlk = Range("D:D").Find(Cells(X1, 4), , , xlWhole).Row
                If Cells(İlk, "E") <> "" Then GoTo Devam
                For X2 = X1 To X1 + Say - 1
                    For X3 = 5 To 35
                        Cells(X2, X3) = Sayı
                        Sayı = Sayı + 1
                        If Sayı > Say Then Sayı = 1
                    Next
                Next
        End Select
Devam:
    Next
        
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

hocam ne diye bilirimki elinize emeinize sağlık tam istediğim gibi olmuş harikasınız. çok teşekkürler
 
Merhaba,

Rica ederim.

Not: Mesajlarınızı yazarken sürekli olarak alıntı yapıp yazmamanızı rica ederim. Forumun altyapısını boşu boşuna şişirmeyelim.
 
onurcan1979' Alıntı:
hocam ne diye bilirimki elinize emeinize sağlık tam istediğim gibi olmuş harikasınız. çok teşekkürler
Genişletmek için tıkla ...

hocam ufak bir sorunla karşılaştımda aynı veri d sütununda alt alta olmayınca veri sayımında hata oluşuyor bunu nasıl çözeriz.

örnek=
d2 hücresi de = dolu
d3 hücresi de = dolu
d4 hücresi de = boş
d5 hücresi de = boş
d6 hücresi de = boş
d7 hücresi de = dolu

olduğunda sayı üretmede hata oluyor d2,d3,d4 sayıyor diğerlerini saymıyor
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst