Soruları ve Cevap Seçeneklerini Karıştır Makrosu

[BedriA]

Arkadaşlar,

Ekte 20 soruluk bir çoktan seçmeli sınav şablonu var.

Ben bu şablon için soruların yerini ve her sorunun cevap seçeneklerini kendi içinde değiştirecek bir makro oluşturmak istiyorum.

Bu makro, eğer sağ üst köşede "B Grubu" yazıyorsa bunu "C Grubu", "A Grubu" yazıyorsa "B Grubu", C Grubu yazıyorsa "D Grubu" olarak da değiştirecek.

Yardımcı olabilir misiniz?

 

[YUSUF44]

Sub GRUP()
If [G4] = "A Grubu" Then [G4] = "B Grubu": GoTo 10
If [G4] = "B Grubu" Then [G4] = "C Grubu": GoTo 10
If [G4] = "C Grubu" Then [G4] = "D Grubu": GoTo 10
If [G4] = "D Grubu" Then [G4] = "A Grubu": GoTo 10
10:
End Sub

 

[BedriA]

Sub GRUP()
If [G4] = "A Grubu" Then [G4] = "B Grubu": GoTo 10
If [G4] = "B Grubu" Then [G4] = "C Grubu": GoTo 10
If [G4] = "C Grubu" Then [G4] = "D Grubu": GoTo 10
If [G4] = "D Grubu" Then [G4] = "A Grubu": GoTo 10
10:
End Sub

Yusuf Hocam,

Can alıcı noktayı ihmal etmişsiniz sanırım.

"Ben bu şablon için soruların yerini ve her sorunun cevap seçeneklerini kendi içinde değiştirecek bir makro oluşturmak istiyorum."

 

[Asri]

Yusuf Hocam,

Can alıcı noktayı ihmal etmişsiniz sanırım.

"Ben bu şablon için soruların yerini ve her sorunun cevap seçeneklerini kendi içinde değiştirecek bir makro oluşturmak istiyorum."

Yani 1. yerine 5.
5. deki a,b,c,d,e seçenekleri yerine b,a,e,c,d mi yazmak istiyorsunuz.

Bu döngüyü tüm sorulara mı uygulamak istiyorsunuz.

 

[BedriA]

Yani 1. yerine 5.
5. deki a,b,c,d,e seçenekleri yerine b,a,e,c,d mi yazmak istiyorsunuz.

Bu döngüyü tüm sorulara mı uygulamak istiyorsunuz.

Aynen... Ama bu işlemi 3 defa yapabilmesi, yani aynı 20 soru, 4 farklı kağıtta, farklı soru (ve seçenek) dizilimleriyle...

İlk kağıt A zaten... İkinci kağıtta soruların ve seçeneklerin yeri değişti, örneğin abcde, baedc oldu ve grup B oldu. Üçüncü kağıt için C olacak grup ve örneğin cadbe olacak gibi.

Makro kaydederek yapmak mümkün. Ama belki döngü kurarak daha kısa bir yol bulunur diye düşündüm. Zira çok uzun kodlar oluşuyor makro kaydedince.

İlginize teşekkür ederim.

 

[Asri]

Dosya ektedir.
Aşağıdaki şekilde deneyiniz.

Bu bilgileri değiştirebilirsiniz. Program şablon sayfasını kullanır.
Kolon yerleri değiştirilmemelidir.

Grup Sayısı 5
Soru Sayısı 10
Seçenek Sayısı 4

Dim grupsayisi, sorusayisi, sorusatir, seceneksayisi As Integer

Sub karistir()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Sheets("Menu").Select
   
   grupsayisi = Cells(5, "J").Value
   sorusayisi = Cells(6, "J").Value
   sorusira = Round(sorusayisi / 2)
   seceneksayisi = Cells(7, "J").Value
   
   For j = 1 To grupsayisi
     grupadi = Chr(64 + j)
     If WorksheetExists(grupadi) Then Sheets(grupadi).Delete
     Sheets("Sablon").Select
     Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
     ActiveSheet.Name = grupadi
     Cells(4, "G").Value = grupadi & " Grubu"
     'Sıralama için sayı üret
     ustsayi = seceneksayisi
     altsayi = 1
     
     soruustsayi = sorusayisi
     sorualtsayi = 1
     
     sorusatir = 2
     kolon = 4
     Range("A1:B" & sorusayisi).ClearContents
            
    For k = 1 To sorusayisi
basla1:
       DoEvents
       Randomize
       sayi = Int((soruustsayi - sorualtsayi + 1) * Rnd + sorualtsayi)
       If WorksheetFunction.CountIf(Range("B1:B" & sorusayisi), sayi) > 0 Then
          GoTo basla1
       End If
       If sayi = sorualtsayi Then sorualtsayi = sayi + 1
       If sayi = soruustsayi Then soruustsayi = sayi - 1
       
       sonsatir = Cells(Rows.Count, "A").End(3).Row
       Range("A1:A" & seceneksayisi).ClearContents
       sorusatir = sorusatir + seceneksayisi + 1
       If kolon = 4 Then soruekle (sorusatir)
       Cells(sorusatir, kolon).Value = sayi & "."
       Cells(k, "B").Value = sayi
       ustsayi = seceneksayisi
       altsayi = 1

     For i = 1 To ustsayi
basla:
       DoEvents
       Randomize
       sayi = Int((ustsayi - altsayi + 1) * Rnd + altsayi)
       If WorksheetFunction.CountIf(Range("A1:A" & seceneksayisi), sayi) > 0 Then
          GoTo basla
       End If
       If sayi = altsayi Then altsayi = sayi + 1
       If sayi = ustsayi Then ustsayi = sayi - 1
       seceneksatir = sorusatir + i
       If kolon = 4 Then secenekekle (seceneksatir)
       Cells(seceneksatir, kolon).Value = Chr(64 + sayi) & "."
       Cells(i, "A").Value = sayi
     Next i
     
     If k = sorusira Then
        kolon = 7
        sorusatir = 2
     End If
      
    Next k
    Range("A1:B" & sorusayisi).ClearContents
   Next j
   
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   MsgBox ("Karıştırma işlemi tamamlandı.")
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

Sub secenekekle(satiri As Integer)
    Rows(satiri & ":" & satiri).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows(satiri & ":" & satiri).RowHeight = 30
End Sub

Sub soruekle(satiri As Integer)
    Rows(satiri & ":" & satiri).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows(satiri & ":" & satiri).RowHeight = 99.75
End Sub

 

[BedriA]

Asri Hocam,

İstediğimden çok daha iyi olmuş.
Elinize, zihninize sağlık.
Ancak şöyle bir sıkıntı var. Ben önce soru sayımı seçiyorum ve
sorularımı sayfaya atıyorum. Bu sayfa örneğin 20 soruluk A Grubu kağıdı oluyor.
Ondan sonra bu kağıt (sayfa) üzerinden diğer grupları oluşturma seçeneği sunuyorum.

Sizin hazırladığınız dosya çalışmaya çok güzel bir boyut kattı. Şöyle ki ben standart A Grubu şablonumda
soru ve seçenek sayılarını seçebileceğim bununla. Yani sizin kod 5 ayrı sayfa yerine tek bir sayfa oluştursa yeter.
30 soru için ayrı, 40 soru için ayrı bir şablona gerek kalmadı.

B, C ve D grubunun oluşması için önce A Grubunun oluşmuş olması gerekiyor ki soru numaraları ve seçenek isimleri (A, B, C, D, E) sabit kalmak
şartı ile sorular ve seçenek içerikleri yer değiştirecek.

Yani kod ile bu değişikliği yaptırmak gerekecek. Bunun için de yeni sayfa oluşturmaya gerek yok sanırım. A Grubu oluşturuldu ve çıktısı alındı.
A grubu üzerinde gerekli değişiklikler yapılarak B grubu oluşturuldu ve çıktı alındı. Bu şekilde devam edecek.

Bunların yanı sıra; beni çok uğraştıran şu problem var:
Bazı soruların bir kısmı diğer sayfaya taşıyor. Taşınca da sayfa numaraları bir garip oluyor.
Normalde her sayfada 2 sütun soru olduğu için, eğer bir sayfada 6 soru varsa,

1 4
2 5
3 6

şeklinde bir dizilim olması gerekiyor. Taşma durumunda
1 4
2 5
3 6
7 10

gibi garip bir hal alıyor.

Soru sayısı, seçenek sayısı belirlemek çok güzel bir özellik oldu çalışmam için.
Ama işte böyle bir sıkıntısı var.

Bunun için ne yapabiliriz acaba?

Ben şimdi bu kodu, soru ve seçenek sayısı belirleyerek kendime şablon oluşturmak için kullanacağım.
Sizden de kırmızı ile yazılmış hususlarda yardım bekliyorum.


Çok teşekkürler.

 

[Asri]

Hazirlarken bana da tuhaf bir istek gibi geldi. Ancak ozellikle sordum ve ornek dosyanizda diger veriler yoktu.
Bu durumda o veriler onemsiz okarak kabul edildi.

 

[BedriA]

Hazirlarken bana da tuhaf bir istek gibi geldi. Ancak ozellikle sordum ve ornek dosyanizda diger veriler yoktu.
Bu durumda o veriler onemsiz okarak kabul edildi.

Ben de tahmin edileceğini varsaydım, daha iyi izah etmeliydim; kusura bakmayın.

 

[BedriA]

Bu arada mevcut kod, bahsettiğim şekilde şablon oluşturmak için de pek kullanışlı olmadı çünkü soru numaraları ve seçenek isimlerinin karışık olması problemi var. Ben sadece 1 grup olursa, sıralı gelir diye düşünmüştüm.

 

[Asri]

Ekli dosyayı deneyiniz.

A sayfası referans sayfadır.
Bu sayfada yapacağınız yazıdırma ayaları diğer sayfalar için de geçerli olacaktır.
Diğer gruplar A sayfasından oluşturulur.

A sayfasında iki kolon halinde sorular olmalı ve diğer kolondaki soru sayısı ya ilk kolona eşit yada bir eksik olabilir. Daha fazlası yada eksiği sorun çıkaracaktır..

Dim grupsayisi, sorusayisi, sorusatir, sorusira, kolon, seceneksatir, seceneksayisi As Integer
Dim grupadi As String


Sub karistir()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Sheets("Menu").Select
   
   grupsayisi = Cells(5, "J").Value
   sorusayisi = Cells(6, "J").Value
   sorusira = Round(sorusayisi / 2)
   seceneksayisi = Cells(7, "J").Value
   For j = Sheets.Count To 3 Step -1
       Sheets(j).Delete
   Next j
   
   For j = 1 To grupsayisi - 1
     grupadi = Chr(65 + j)
     Sheets("A").Select
     Sheets("A").Copy After:=Sheets(Sheets.Count)
     ActiveSheet.Name = grupadi
     Cells(4, "G").Value = grupadi & " Grubu"
     'Sıralama için sayı üret
     ustsayi = seceneksayisi
     altsayi = 1
     
     soruustsayi = sorusayisi
     sorualtsayi = 1
     
     sorusatir = 2
     kolon = 4
     Range("A1:B" & sorusayisi).ClearContents
            
    For k = 1 To sorusayisi
basla1:
       DoEvents
       Randomize
       sayi1 = Int((soruustsayi - sorualtsayi + 1) * Rnd + sorualtsayi)
       If WorksheetFunction.CountIf(Range("B1:B" & sorusayisi), sayi1) > 0 Then
          GoTo basla1
       End If
       If sayi1 = sorualtsayi Then sorualtsayi = sayi1 + 1
       If sayi1 = soruustsayi Then soruustsayi = sayi1 - 1
       
       sonsatir = Cells(Rows.Count, "A").End(3).Row
       Range("A1:A" & seceneksayisi).ClearContents
       If sorusatir = 2 Then sorusatir = 8 Else sorusatir = sorusatir + seceneksayisi + 1
       'If kolon = 4 Then soruekle (sorusatir)
       Cells(sorusatir, kolon).Select
       Cells(sorusatir, kolon).Value = sayi1 & "."

       Cells(k, "B").Value = sayi1

       ustsayi = seceneksayisi
       altsayi = 1
       

     For i = 1 To ustsayi
basla:
       DoEvents
       Randomize
       sayi = Int((ustsayi - altsayi + 1) * Rnd + altsayi)
       If WorksheetFunction.CountIf(Range("A1:A" & seceneksayisi), sayi) > 0 Then
          GoTo basla
       End If
       If sayi = altsayi Then altsayi = sayi + 1
       If sayi = ustsayi Then ustsayi = sayi - 1
       seceneksatir = sorusatir + i
       'If kolon = 4 Then secenekekle (seceneksatir)
       Cells(seceneksatir, kolon).Value = Chr(64 + sayi) & "."
       Cells(i, "A").Value = sayi
     Next i
       
     Call seceneksirala
     
       If k = sorusira Then
          kolon = 7
          sorusatir = 2
       End If
      
    Next k
    
    Range("A1:B" & sorusayisi).ClearContents
    Call soruyerlestir
    Cells(1, 1).Select
   Next j
   
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   MsgBox ("Karıştırma işlemi tamamlandı.")
End Sub

Sub soruyerlestir()
 sorusatira = 2
 kolona = 4
  For j1 = 1 To sorusayisi
     If sorusatira = 2 Then sorusatira = 8 Else sorusatira = sorusatira + seceneksayisi + 1
     
     sorunoj = Cells(sorusatira, kolona).Value
     If sorunoj = j1 & "." Then GoTo son

     Range(Cells(sorusatira, kolona), Cells(sorusatira + seceneksayisi, kolona + 1)).Select
     Selection.Copy
     Cells(8, "B").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
     Range(Cells(sorusatira, kolona), Cells(sorusatira + seceneksayisi, kolona + 1)).Select
     Selection.Clear
     sorusatirg = 2
     kolong = 4
     For i1 = 1 To sorusayisi
        If sorusatirg = 2 Then sorusatirg = 8 Else sorusatirg = sorusatirg + seceneksayisi + 1
        soruno = Cells(sorusatirg, kolong).Value
        If soruno = j1 & "." Then
          a = a
          Cells(sorusatirg, kolong).Select
          Range(Cells(sorusatirg, kolong), Cells(sorusatirg + seceneksayisi, kolong + 1)).Select
          Selection.Copy
          Cells(sorusatira, kolona).Select
          ActiveSheet.Paste
          Application.CutCopyMode = False
          Range(Cells(sorusatirg, kolong), Cells(sorusatirg + seceneksayisi, kolong + 1)).Select
          Selection.Clear
          
          Cells(8, "B").Select
          Range(Cells(8, "B"), Cells(8 + seceneksayisi, "C")).Select
          Selection.Copy
          Cells(sorusatirg, kolong).Select
          ActiveSheet.Paste
          Application.CutCopyMode = False
          Range(Cells(8, "B"), Cells(8 + seceneksayisi, "C")).Select
          Selection.Clear
          Cells(sorusatira, kolona).Select
          a = a
        End If
        
        If i1 = sorusira Then
         kolong = 7
         sorusatirg = 2
        End If
     Next i1
son:
     If j1 = sorusira Then
         kolona = 7
         sorusatira = 2
     End If
        
   Next j1
   Range(Cells(8, "B"), Cells(8 + seceneksayisi, "C")).Select
   Selection.Clear
End Sub

Sub seceneksirala()
    Range(Cells(sorusatir + 1, kolon), Cells(seceneksatir, kolon + 1)).Select
    ActiveWorkbook.Worksheets(grupadi).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(grupadi).Sort.SortFields.Add Key:=Range(Cells(sorusatir + 1, kolon), Cells(seceneksatir, kolon)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(grupadi).Sort
        .SetRange Range(Cells(sorusatir + 1, kolon), Cells(seceneksatir, kolon + 1))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

 

[BedriA]

Çok sağol Asri Hocam.
Hemen inceliyorum.

 

[BedriA]

Asri Hocam,

Sayfada bir tane buton var ama birden fazla kod var.
Ben bu kodu userform üzerindeki butonlara atayacağım.
Sanırım hücrelere makro atamışsınız. Doğru mu?

İlk kolon 1-10, ikincisi 11-20 numaralarını almış.
Oysa bunun her sayfada ardışık olması gerekirdi.

1. Sayfa
1 4
2 5
3 6
2. Sayfa
7 10
8 11
9 12 gibi.

Bu arada; referans sayfası hazır, yani soru sayısı belli olduğu için soru sayısı girmeye gerek yok sanırım. Aynı şey seçenek sayısı için de geçerli. Birkaç sorum olacak:

Soru 1: Seçenek sayısı 4 olsa, yine karıştırma işlemi yapar mı?

Soru 2: Tek değişken grup sayısı olmayacak mı?

Soru 3: Referans sayfasında soru sayısı kaç olursa olsun yine de kod çalışacak mı?

 

[Asri]

Bu kısım hariç diğerleri tamam.
Bu kısım biraz karışık. Zaman lazım.

..

1. Sayfa
1 4
2 5
3 6
2. Sayfa
7 10
8 11
9 12 gibi.

Soru sayısını A sayfasındaki "A." ları sayarak tespit ediyor.
Seçenek sayısını 9. satırdan, sonraki sayıya kadar olan harf leri sayarak tespit ediyor.
4 seçenek yada 10 seçenekli yapabilirsiniz. Porgram ona göre işlem yapacaktır.

A sayfasında iki kolon halinde sorular olmalı ve diğer kolondaki soru sayısı ya ilk kolona eşit yada bir eksik olabilir. Daha fazlası yada eksiği sorun çıkaracaktır..

 

[BedriA]

Çok teşekkür ederim.
Elinize sağlık.