Bir Hücredeki Satırların Yerini Değiştirme

BedriA · 2 Ağustos 2017

Arkadaşlar,

Mümkün mü bilmiyorum, araştırdım ama bir şey bulamadım.
Pek umudum olmasa da bir konu açmak istedim yine de.

Bir hücrede aşağıdaki şekilde bir veri olsun.
Soru bir satır, şıkların her biri bir satırda; satırdan kastim hücre içinde satır... Alt+Enter olayı yani.

Aşağıda verilen cümlelerin hangisinde ünlü düşmesi gerçekleşmiştir?

A) Bana hiç çiçek göndermeyin
B) Bir meyve ağacı gönderin.
C) Ağzıma onları atayım.
D) Afiyetle yiyeyim.

A, B, C, D yerinde kalacak şekilde, A, B, C ve D'den sonraki verilerin yerlerini kendi arasında değiştirebilir miyiz acaba?

PLİNT · 3 Ağustos 2017

Merhaba
Ek dosyayı denermisiniz?

http://s6.dosya.tc/server9/fq92yk/deneme.zip.html

Kod:

[SIZE="2"]Private Sub CommandButton1_Click()
Dim a, b, c, d As String
Dim x1, x2, x3, x4 As Long
Dim f, data As Variant
a = Replace(Replace(Mid([A1], InStr(1, [A1], "A)"), InStr(1, [A1], "B)") - InStr(1, [A1], "A)")), "A)", ""), Chr(10), "")
b = Replace(Replace(Mid([A1], InStr(1, [A1], "B)"), InStr(1, [A1], "C)") - InStr(1, [A1], "B)")), "B)", ""), Chr(10), "")
c = Replace(Replace(Mid([A1], InStr(1, [A1], "C)"), InStr(1, [A1], "D)") - InStr(1, [A1], "C)")), "C)", ""), Chr(10), "")
d = Split([A1], "D)")(1)
data = UniqueRandomNumbers(4, 1, 4)
f = Array(a, b, c, d)
x1 = data(1): x2 = data(2): x3 = data(3): x4 = data(4)
[A1] = Replace([A1], "A)" & a, "A)" & f(x1 - 1))
[A1] = Replace([A1], "B)" & b, "B)" & f(x2 - 1))
[A1] = Replace([A1], "C)" & c, "C)" & f(x3 - 1))
[A1] = Replace([A1], "D)" & d, "D)" & f(x4 - 1))
End Sub
 [/SIZE]

Kod:

[SIZE="2"]

' [URL="http://techqa.info/programming/question/10651553/Randomize-Columns"]http://techqa.info/programming/question/10651553/Randomize-Columns[/URL]

Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, ULimit As Long) As Variant
    Dim RandColl As Collection, i As Long, varTemp() As Long
    UniqueRandomNumbers = False
    If NumCount < 1 Then Exit Function
    If LLimit > ULimit Then Exit Function
    If NumCount > (ULimit - LLimit + 1) Then Exit Function
    Set RandColl = New Collection
    Randomize
    Do
        On Error Resume Next
        i = CLng(Rnd * (ULimit - LLimit) + LLimit)
        RandColl.Add i, CStr(i)
        On Error GoTo 0
    Loop Until RandColl.Count = NumCount
    ReDim varTemp(1 To NumCount)
    For i = 1 To NumCount
        varTemp(i) = RandColl(i)
    Next i
    Set RandColl = Nothing
    UniqueRandomNumbers = varTemp
    Erase varTemp
End Function[/SIZE]

BedriA · 3 Ağustos 2017

Hocam çok teşekkürler.
Müthiş işime yarayan bir kod oldu.
Öğrenciler için kötü ama benim için çok iyi oldu bu.

Küçük bir isteğim daha olacak.

For-Next döngüsü ile bazen 20, bazen de 50 soru için, alt alta bu sorular, A1-A50 aralığında, kodu döndürmek mümkün mü?

Beş seçenek için uyarlama yaptım ama bunu beceremedim. +
Hocam bir de; kodların içinde sayfa ismi göremedim, sanırım aktif sayada çalışıyor.
Kodu sayfaya özel hala getirmek mümkün olsaydı keşke.

Tekrardan çok teşekkür ederim.

Selam ve saygılarımla.

Beşli olan için kod aşağıda:

Kod:

Sub dene()


Dim a, b, c, d, e As String
Dim x1, x2, x3, x4, x5 As Long
Dim f, data As Variant
For i = 1 To 2
a = Replace(Replace(Mid([A1], InStr(1, [A1], "A)"), InStr(1, [A1], "B)") - InStr(1, [A1], "A)")), "A)", ""), Chr(10), "")
b = Replace(Replace(Mid([A1], InStr(1, [A1], "B)"), InStr(1, [A1], "C)") - InStr(1, [A1], "B)")), "B)", ""), Chr(10), "")
c = Replace(Replace(Mid([A1], InStr(1, [A1], "C)"), InStr(1, [A1], "D)") - InStr(1, [A1], "C)")), "C)", ""), Chr(10), "")
d = Replace(Replace(Mid([A1], InStr(1, [A1], "D)"), InStr(1, [A1], "E)") - InStr(1, [A1], "D)")), "D)", ""), Chr(10), "")
e = Split([A1], "E)")(1)
data = UniqueRandomNumbers(5, 1, 5)
f = Array(a, b, c, d, e)
x1 = data(1): x2 = data(2): x3 = data(3): x4 = data(4): x5 = data(5)
[A1] = Replace([A1], "A)" & a, "A)" & f(x1 - 1))
[A1] = Replace([A1], "B)" & b, "B)" & f(x2 - 1))
[A1] = Replace([A1], "C)" & c, "C)" & f(x3 - 1))
[A1] = Replace([A1], "D)" & d, "D)" & f(x4 - 1))
[A1] = Replace([A1], "E)" & e, "E)" & f(x5 - 1))
Next i
End Sub

PLİNT · 3 Ağustos 2017

Merhaba
Ekte bulunan zip klasöründe 2 dosya bulunuyor,
biri 5 seçenek için,
diğeri "A" sütununda hem 4, hem 5 seçenekli sorular olma ihtimali içindir.
http://s6.dosya.tc/server9/j1lv84/denemeler.zip.html

PLİNT · 3 Ağustos 2017

BedriA' Alıntı:
Hocam bir de; kodların içinde sayfa ismi göremedim, sanırım aktif sayada çalışıyor.
Kodu sayfaya özel hala getirmek mümkün olsaydı keşke.

http://s6.dosya.tc/server9/j1lv84/denemeler.zip.html
Dosyalarda kodlar modülde olduğu için hangi sayfa açık ise çalıştırılan sayfaya özel olacaktır, sizin istediğiniz sayfa/sayfalar açılmadan ise bir örnek dosya
eklerseniz üzerinde yapabiliriz.

BedriA · 3 Ağustos 2017

Çok teşekkürler hocam. Cepten yazıyorum şu an, bilgisayara geçince hemen indirip bakacağım.

BedriA · 3 Ağustos 2017

Hocam şimdi inceledim.
Çok teşekkürler. Bu kod olmasa şıkların her birini ayrı bir
hücreye yazmak gerekecekti, değiştirebilmek için.

Çok sağolun.

BedriA · 3 Ağustos 2017

PLİNT' Alıntı:
http://s6.dosya.tc/server9/j1lv84/denemeler.zip.html
Dosyalarda kodlar modülde olduğu için hangi sayfa açık ise çalıştırılan sayfaya özel olacaktır, sizin istediğiniz sayfa/sayfalar açılmadan ise bir örnek dosya
eklerseniz üzerinde yapabiliriz.

Aşağıda verilen cümlelerin hangisinde ünlü düşmesi gerçekleşmiştir?

A) Ağzıma onları atayım.
B) Bir meyve ağacı gönderin.
C) Afiyetle yiyeyim.
D) Bana hiç çiçek göndermeyin
E) Ağaçlar çiçek açmış

B sütununda:

Doğru cevap: Ağaçlar çiçek açmış

C sütununda ise "E" yazıyor.

Karıştırmadan sonra doğru cevabı metinde arayıp ona göre
C sütununa şıkkı yazması mümkün mü acaba?

PLİNT · 3 Ağustos 2017

Merhaba
Aşağıdaki gibi değişiklik yaparak denermisiniz?

Kod:

[SIZE="2"]Sub karıştır()
Dim a, b, c, d, e[COLOR="Blue"], deg[/COLOR] As String
Dim x1, x2, x3, x4, x5 As Long
Dim f, data As Variant
For j = 1 To Cells(Rows.Count, "A").End(3).Row
[COLOR="Blue"]deg = Trim(Cells(j, "B"))[/COLOR]
a = Replace(Replace(Mid(Cells(j, "A"), InStr(1, Cells(j, "A"), "A)"), InStr(1, Cells(j, "A"), "B)") - InStr(1, Cells(j, "A"), "A)")), "A)", ""), Chr(10), "")
b = Replace(Replace(Mid(Cells(j, "A"), InStr(1, Cells(j, "A"), "B)"), InStr(1, Cells(j, "A"), "C)") - InStr(1, Cells(j, "A"), "B)")), "B)", ""), Chr(10), "")
c = Replace(Replace(Mid(Cells(j, "A"), InStr(1, Cells(j, "A"), "C)"), InStr(1, Cells(j, "A"), "D)") - InStr(1, Cells(j, "A"), "C)")), "C)", ""), Chr(10), "")
d = Replace(Replace(Mid(Cells(j, "A"), InStr(1, Cells(j, "A"), "D)"), InStr(1, Cells(j, "A"), "E)") - InStr(1, Cells(j, "A"), "D)")), "D)", ""), Chr(10), "")
e = Split(Cells(j, "A"), "E)")(1)
data = UniqueRandomNumbers(5, 1, 5)
f = Array(a, b, c, d, e)
x1 = data(1): x2 = data(2): x3 = data(3): x4 = data(4): x5 = data(5)
Cells(j, "A") = Replace(Cells(j, "A"), "A)" & a, "A)" & f(x1 - 1))
  [COLOR="Blue"]If Trim(f(x1 - 1)) = deg Then Cells(j, "C") = "A"[/COLOR]
Cells(j, "A") = Replace(Cells(j, "A"), "B)" & b, "B)" & f(x2 - 1))
  [COLOR="Blue"] If Trim(f(x2 - 1)) = deg Then Cells(j, "C") = "B"[/COLOR]
Cells(j, "A") = Replace(Cells(j, "A"), "C)" & c, "C)" & f(x3 - 1))
  [COLOR="Blue"] If Trim(f(x3 - 1)) = deg Then Cells(j, "C") = "C"[/COLOR]
Cells(j, "A") = Replace(Cells(j, "A"), "D)" & d, "D)" & f(x4 - 1))
  [COLOR="Blue"] If Trim(f(x4 - 1)) = deg Then Cells(j, "C") = "D"[/COLOR]
Cells(j, "A") = Replace(Cells(j, "A"), "E)" & e, "E)" & f(x5 - 1))
   [COLOR="Blue"]If Trim(f(x5 - 1)) = deg Then Cells(j, "C") = "E"[/COLOR]
Erase data
Next
End Sub[/SIZE]

BedriA · 3 Ağustos 2017

Aldığım hatanın ekran görüntüsü ektedir.

PLİNT · 3 Ağustos 2017

Merhaba
Kodlar "Deneme" adlı 5 seçenekli dosya içindi,
"4-5 seçenekli" adlı dosyada denediğiniz için hata vermiş
Aşağıdaki ek içindeki dosyaları deneyin;
2 adet dosya bulunuyor
"Hatalı" adlı dosyada hücrede şıkların olmaması gereken satır şekilleri bulunuyor.
http://s6.dosya.tc/server9/k29mb8/DENEMELER2.zip.html

BedriA · 3 Ağustos 2017

PLİNT' Alıntı:
Merhaba
Kodlar "Deneme" adlı 5 seçenekli dosya içindi,
"4-5 seçenekli" adlı dosyada denediğiniz için hata vermiş
Aşağıdaki ek içindeki dosyaları deneyin;
2 adet dosya bulunuyor
"Hatalı" adlı dosyada hücrede şıkların olmaması gereken satır şekilleri bulunuyor.
http://s6.dosya.tc/server9/k29mb8/DENEMELER2.zip.html

Hocam elinize sağlık.
Ben şimdi değişik kombinasyonlarla denerim.

Çok teşekkür ederim.

Dosyadan yararlanmak için site içi indirme linki ektedir.

BedriA · 3 Ağustos 2017

Hocam kodu kendi dosyamda kullanmaya başladım.
Doğru işlem yapıyor ancak hata veriyor yine.

Kısa bir video çektim konuyla ilgili.
Buradan indirip izledikten sonra geri dönüş yaparsanız sevinirim.

PLİNT · 3 Ağustos 2017

Merhaba

Kod:

For j = 1 To Cells(Rows.Count, "A").End(3).Row

Döngü sizin videodaki dosyaya göre 2. satırda bitmeli ama "A" sütununun aşadaki hücrelerinden birinde veya fazlasında veri var demekki,
veri olarak hücrede (" ") boşluk bile olsa döngü son dolu satır olarak o hücreyi görür. A" sütununda 3. hücreden başlayarak aşağı doğru çokça seçim yapıp
içeriği temizleyin, veya aşağıdaki mavi bölümü ekleyin.
("Goto 12 yerine boşluğu görünce döngüyü bitirmek için "exit sub" )

Kod:

Sub karıştır()
Dim a, b, c, d, e As String
Dim x1, x2, x3, x4, x5 As Long
Dim f, data As Variant
Dim geri
For j = 1 To Cells(Rows.Count, "A").End(3).Row
[COLOR="Blue"]If Trim(Cells(j, "A")) = "" Then [COLOR="Red"]GoTo 12[/COLOR][/COLOR]
'....
'....diğer kodlarınız

Bir Hücredeki Satırların Yerini Değiştirme

BedriA

PLİNT

BedriA

PLİNT

PLİNT

BedriA

BedriA

BedriA

PLİNT

BedriA

Ekli dosyalar

PLİNT

BedriA

Ekli dosyalar

BedriA

Ekli dosyalar

PLİNT