toplam değeri sutunlara rastgele dağıtma

[fsahinoglu]

aslında dediğin doğru öğrenci derse hazırlık gelmiş 20 puan max değeri almış gerisi 0 0 sorarlar hocam nasıl iş bu diye

 

[fsahinoglu]

5 in katları daha mantıklı eğitim sisteminde sözlü notları ve resim derslerinde en çok kullanılan puan aralığı

 

[fsahinoglu]

aslında düzeltmeye gerek yok 20 yazarsam tekrar farklı üretiyor sonuçta akşam akşamda uğraşmayalım eline sağlık arkadaşım çok güzel oldu tam aradığım gibi

 

[Muhammet Okumuş]

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Intersect(Target, Range("I6:I200")) Is Nothing Then GoTo 1
x = Target.Row
nott = Cells(x, 9).Value
Range("D" & x & ":H" & x) = 20
If Cells(x, 9) = 100 Then Exit Sub
10
b = WorksheetFunction.RandBetween(4, 8)
az = WorksheetFunction.Min(Range("D" & x & ":H" & x))
çok = WorksheetFunction.Max(Range("D" & x & ":H" & x))
If Cells(x, b) = az And çok - az > 9 Then GoTo 10
If Cells(x, b) = 0 Then GoTo 10
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("D" & x & ":H" & x)) = nott Then Exit Sub
GoTo 10
1
If Intersect(Target, Range("O6:O200")) Is Nothing Then GoTo 2
x = Target.Row
nott = Cells(x, 15).Value
Range("J" & x & ":N" & x) = 20
If Cells(x, 15) = 100 Then Exit Sub
20
b = WorksheetFunction.RandBetween(10, 14)
az = WorksheetFunction.Min(Range("J" & x & ":N" & x))
çok = WorksheetFunction.Max(Range("J" & x & ":N" & x))
If Cells(x, b) = az And çok - az > 9 Then GoTo 20
If Cells(x, b) = 0 Then GoTo 20
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("J" & x & ":N" & x)) = nott Then Exit Sub
GoTo 20
2
If Intersect(Target, Range("U6:U200")) Is Nothing Then GoTo 3
x = Target.Row
nott = Cells(x, 21).Value
Range("P" & x & ":T" & x) = 20
If Cells(x, 21) = 100 Then Exit Sub
30
b = WorksheetFunction.RandBetween(16, 20)
az = WorksheetFunction.Min(Range("P" & x & ":T" & x))
çok = WorksheetFunction.Max(Range("P" & x & ":T" & x))
If Cells(x, b) = az And çok - az > 9 Then GoTo 30
If Cells(x, b) = 0 Then GoTo 30
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("P" & x & ":T" & x)) = nott Then Exit Sub
GoTo 30
3
End Sub

En büyük not ile en küçük not arası en fazla 10 olabilir şeklinde düzenledim.

 

[fsahinoglu]

20
b = WorksheetFunction.RandBetween(16, 20)
If Cells(x, b) = 0 Then GoTo 20

10 olanı da 20 yaptım düzeldi diğer sütünda

 

[fsahinoglu]

son kod çok mantıklı oldu hakkatten işi biliyorsun arkadaşım sağol tam takır çalışıyor

 

[fsahinoglu]

saatte çok geç olmuş sahura kalkacam 2 saat uyku çekeyim hayırlı sahurlar

 

[Muhammet Okumuş]

Sana da hayırlı sahurlar.

 

[fsahinoglu]

hücreye girilen değerin 5 in katı olup olmadığını sorgulattırma imkanımız var mı acaba
misal formda 17 kayıt girdim 18. girerken 5 katı olmadığında excell gümledi yine
Msgbox şeklinde uyarı versin 5 katı değil

 

[Muhammet Okumuş]

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Intersect(Target, Range("I6:I200")) Is Nothing Then GoTo 1
If Target Mod 5 <> 0 Then
MsgBox "Sayı 5'in katı olmalıdır.", vbInformation, "Uyarı"
Exit Sub
End If

x = Target.Row
nott = Cells(x, 9).Value
Range("D" & x & ":H" & x) = 20
If Cells(x, 9) = 100 Then Exit Sub
10
b = WorksheetFunction.RandBetween(4, 8)
az = WorksheetFunction.Min(Range("D" & x & ":H" & x))
çok = WorksheetFunction.Max(Range("D" & x & ":H" & x))
If Cells(x, b) = az And çok - az > 9 Then GoTo 10
If Cells(x, b) = 0 Then GoTo 10
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("D" & x & ":H" & x)) = nott Then Exit Sub
GoTo 10
1
If Intersect(Target, Range("O6:O200")) Is Nothing Then GoTo 2
If Target Mod 5 <> 0 Then
MsgBox "Sayı 5'in katı olmalıdır.", vbInformation, "Uyarı"
Exit Sub
End If

x = Target.Row
nott = Cells(x, 15).Value
Range("J" & x & ":N" & x) = 20
If Cells(x, 15) = 100 Then Exit Sub
20
b = WorksheetFunction.RandBetween(10, 14)
az = WorksheetFunction.Min(Range("J" & x & ":N" & x))
çok = WorksheetFunction.Max(Range("J" & x & ":N" & x))
If Cells(x, b) = az And çok - az > 9 Then GoTo 20
If Cells(x, b) = 0 Then GoTo 20
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("J" & x & ":N" & x)) = nott Then Exit Sub
GoTo 20
2
If Intersect(Target, Range("U6:U200")) Is Nothing Then GoTo 3
If Target Mod 5 <> 0 Then
MsgBox "Sayı 5'in katı olmalıdır.", vbInformation, "Uyarı"
Exit Sub
End If

x = Target.Row
nott = Cells(x, 21).Value
Range("P" & x & ":T" & x) = 20
If Cells(x, 21) = 100 Then Exit Sub
30
b = WorksheetFunction.RandBetween(16, 20)
az = WorksheetFunction.Min(Range("P" & x & ":T" & x))
çok = WorksheetFunction.Max(Range("P" & x & ":T" & x))
If Cells(x, b) = az And çok - az > 9 Then GoTo 30
If Cells(x, b) = 0 Then GoTo 30
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("P" & x & ":T" & x)) = nott Then Exit Sub
GoTo 30
3
End Sub

Kodu deneyiniz.

 

[fsahinoglu]

süper oldu eline sağlık arkadaşım bitti

 

[fsahinoglu]

sayfama bir tane form oluşturdum formdan gelen bilgilere göre sınıf mevcudu sayısı kadar hücreler oluştururken

bu kodlan :

Private Sub CommandButton1_Click()
If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Or TextBox6.Value = "" Or TextBox7.Value = "" Or TextBox8.Value = "" Or TextBox8.Value = "" Or TextBox9.Value = "" Or TextBox10.Value = "" Or TextBox11.Value = "" Then
MsgBox ("Lütfen Tüm Alanları Doldurunuz")
Else
sayi = CInt(TextBox5.Value)
Sheets("şablon").Copy After:=Worksheets(Worksheets.Count)

TextBox1.Value = UCase(TextBox1.Value)
TextBox2.Value = UCase(TextBox2.Value)
TextBox3.Value = UCase(TextBox3.Value)
TextBox4.Value = UCase(TextBox4.Value)
TextBox5.Value = UCase(TextBox5.Value)
TextBox6.Value = UCase(TextBox6.Value)
TextBox7.Value = UCase(TextBox7.Value)
TextBox8.Value = UCase(TextBox8.Value)
TextBox9.Value = UCase(TextBox9.Value)
TextBox10.Value = UCase(TextBox10.Value)
TextBox11.Value = UCase(TextBox11.Value)
Dim deg As String
deg = Mid(TextBox2.Text, 1, 3)

ActiveSheet.Name = (TextBox3.Text) & "-" & (TextBox4.Text) & " " & deg
ActiveSheet.Range("A2").Value = (TextBox1.Value) & " " & (TextBox6.Value) & " EĞİTİM ÖĞRETİM YILI " & (TextBox7.Value) & ". DÖNEM "
ActiveSheet.Range("A3").Value = (TextBox2.Value) & " DERSİ DEĞERLENDİRME FORMU"
ActiveSheet.Range("T2").Value = (TextBox3.Value) & "/" & (TextBox4.Value) & " SINIFI"
Cells(7, 1).Select

Call SatirEkle

UserForm1.Hide
End If
End Sub

Sub SatirEkle()

Dim x As Byte



For x = 1 To sayi - 2
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Next x

sayi1 = CInt(TextBox5.Value)
ActiveSheet.Range("d" & sayi1 + 12).Value = (TextBox8.Value)
ActiveSheet.Range("d" & sayi1 + 13).Value = (TextBox9.Value) & " ÖĞRT."
ActiveSheet.Range("A1").Value = sayi1

sayi2 = CInt(TextBox5.Value)

ActiveSheet.Range("r" & sayi2 + 12).Value = (TextBox11.Value)
ActiveSheet.Range("r" & sayi2 + 13).Value = "UYGUNDUR"
ActiveSheet.Range("r" & sayi2 + 14).Value = (TextBox10.Value)
ActiveSheet.Range("r" & sayi2 + 15).Value = "OKUL MÜD."
ActiveSheet.Range("A1").Value = sayi2

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:=True

Cells(7, 1).Select


For x = 1 To sayi
ActiveSheet.Range("A" & x + 6).Value = x

Next x

End Sub


hani 5 in katı uyarısı vardıya o satırda kod uyarı hatası veriyor

If Target Mod 5 <> 0 Then

niye yapıyor ki


dosya ekledim : http://www.dosya.tc/server2/e57v4g/son_durum.rar.html

 

[fsahinoglu]

biraz araştırınca bir konuya denk geldim veri menüsünden veriyi koru seçip ilgili sutunu seçtikten sonra =MOD(b2;5)=0 şeklinde otomatik olarak veriler 5 in katı oluyor

 

[Muhammet Okumuş]

rivate Sub CommandButton1_Click()
Application.EnableEvents = False
If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Or TextBox6.Value = "" Or TextBox7.Value = "" Or TextBox8.Value = "" Or TextBox8.Value = "" Or TextBox9.Value = "" Or TextBox10.Value = "" Or TextBox11.Value = "" Then
MsgBox ("Lütfen Tüm Alanları Doldurunuz")
Else
sayi = CInt(TextBox5.Value)
Sheets("şablon").Copy After:=Worksheets(Worksheets.Count)

TextBox1.Value = UCase(TextBox1.Value)
TextBox2.Value = UCase(TextBox2.Value)
TextBox3.Value = UCase(TextBox3.Value)
TextBox4.Value = UCase(TextBox4.Value)
TextBox5.Value = UCase(TextBox5.Value)
TextBox6.Value = UCase(TextBox6.Value)
TextBox7.Value = UCase(TextBox7.Value)
TextBox8.Value = UCase(TextBox8.Value)
TextBox9.Value = UCase(TextBox9.Value)
TextBox10.Value = UCase(TextBox10.Value)
TextBox11.Value = UCase(TextBox11.Value)
Dim deg As String
deg = Mid(TextBox2.Text, 1, 3)

ActiveSheet.Name = (TextBox3.Text) & "-" & (TextBox4.Text) & " " & deg
ActiveSheet.Range("A2").Value = (TextBox1.Value) & " " & (TextBox6.Value) & " EĞİTİM ÖĞRETİM YILI " & (TextBox7.Value) & ". DÖNEM "
ActiveSheet.Range("A3").Value = (TextBox2.Value) & " DERSİ DEĞERLENDİRME FORMU"
ActiveSheet.Range("T2").Value = (TextBox3.Value) & "/" & (TextBox4.Value) & " SINIFI"
Cells(7, 1).Select

Call SatirEkle

UserForm1.Hide
End If
Application.EnableEvents = True
End Sub

Kodu deneyiniz.

 

[fsahinoglu]

Application.EnableEvents = True false olayımı hallediyor bu işi
sağol muhammet çok emeğin geçti bitti rahat rahat not verebilirim

 

[fsahinoglu]

sayfayıkilitleyip korumalı yapınca

ActiveCell.Offset(1, 0).EntireRow.Insert

bu satırda hata uyarı vermesinin nedeni nedir anlamadım

 

[fsahinoglu]

ActiveSheet.Unprotect Password:="şifre" kodun başına ve sonuna bunu koyuna düzeldi

ActiveSheet.Protect Password:="şifre tekrar"

 

[fsahinoglu]

bu seferde kodları koymama rağmen
bu satırdaki hatayı alıyorum o satıda korumalı satır
ActiveSheet.Range("A2").Value = (TextBox1.Value) & " " & (TextBox6.Value) & " EĞİTİM ÖĞRETİM YILI " & (TextBox7.Value) & ". DÖNEM "

anlam veremedim gitti



Private Sub CommandButton1_Click()

ActiveSheet.Unprotect Password:="şifre"

If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Or TextBox6.Value = "" Or TextBox7.Value = "" Or TextBox8.Value = "" Or TextBox8.Value = "" Or TextBox9.Value = "" Or TextBox10.Value = "" Or TextBox11.Value = "" Then
MsgBox ("Lütfen Tüm Alanları Doldurunuz")
Else
sayi = CInt(TextBox5.Value)
Sheets("şablon").Copy After:=Worksheets(Worksheets.Count)

TextBox1.Value = UCase(TextBox1.Value)
TextBox2.Value = UCase(TextBox2.Value)
TextBox3.Value = UCase(TextBox3.Value)
TextBox4.Value = UCase(TextBox4.Value)
TextBox5.Value = UCase(TextBox5.Value)
TextBox6.Value = UCase(TextBox6.Value)
TextBox7.Value = UCase(TextBox7.Value)
TextBox8.Value = UCase(TextBox8.Value)
TextBox9.Value = UCase(TextBox9.Value)
TextBox10.Value = UCase(TextBox10.Value)
TextBox11.Value = UCase(TextBox11.Value)
Dim deg As String
deg = Mid(TextBox2.Text, 1, 3)

ActiveSheet.Name = (TextBox3.Text) & "-" & (TextBox4.Text) & " " & deg
ActiveSheet.Range("A2").Value = (TextBox1.Value) & " " & (TextBox6.Value) & " EĞİTİM ÖĞRETİM YILI " & (TextBox7.Value) & ". DÖNEM "
ActiveSheet.Range("A3").Value = (TextBox2.Value) & " DERSİ DEĞERLENDİRME FORMU"
ActiveSheet.Range("T2").Value = (TextBox3.Value) & "/" & (TextBox4.Value) & " SINIFI"
Cells(7, 1).Select

Call SatirEkle

UserForm1.Hide
End If

ActiveSheet.Protect Password:="şifre tekrar"
End Sub