Merhabalar,
Sınav sorularını hazırladığım bir excel elimde mevcut fakat dış kaynaktan soru al seçeneğine birden fazla soru kopyaladığım zaman sadece 1 soruyu alıyor vb kodlarında yapmam gereken bir değişiklik var mı ? yardımcı olabilir misiniz ?
Teşekkürler
İyi Çalışmalar.
Sınav sorularını hazırladığım bir excel elimde mevcut fakat dış kaynaktan soru al seçeneğine birden fazla soru kopyaladığım zaman sadece 1 soruyu alıyor vb kodlarında yapmam gereken bir değişiklik var mı ? yardımcı olabilir misiniz ?
Kod:
Private Sub btnAktar_Click()
On Local Error GoTo Hata:
Dim soruMetni As String
Dim Enter, secA, secB, secC, secD, secE As Integer
Dim paragraf, soruKoku, secenekA, secenekB, secenekC, secenekD, secenekE As String
soruMetni = txtSoru.Text
If InStr(1, soruMetni, vbTab) < 7 Then
soruMetni = Mid(soruMetni, InStr(1, soruMetni, vbTab) + 1, Len(soruMetni))
End If
For i = 1 To Len(soruMetni) - 2
If Mid(soruMetni, i, 3) = "a) " Or _
Mid(soruMetni, i, 3) = "a)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "a. " Or _
Mid(soruMetni, i, 3) = "a." & Chr(9) Or _
Mid(soruMetni, i, 3) = "a- " Or _
Mid(soruMetni, i, 3) = "a-" & Chr(9) Or _
Mid(soruMetni, i, 3) = "A) " Or _
Mid(soruMetni, i, 3) = "A)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "A. " Or _
Mid(soruMetni, i, 3) = "A." & Chr(9) Or _
Mid(soruMetni, i, 3) = "A- " Or _
Mid(soruMetni, i, 3) = "A-" & Chr(9) Then
secA = i
Exit For
End If
Next i
For i = secA To Len(soruMetni) - 2
If Mid(soruMetni, i, 3) = "b) " Or _
Mid(soruMetni, i, 3) = "b)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "b. " Or _
Mid(soruMetni, i, 3) = "b." & Chr(9) Or _
Mid(soruMetni, i, 3) = "b- " Or _
Mid(soruMetni, i, 3) = "b-" & Chr(9) Or _
Mid(soruMetni, i, 3) = "B) " Or _
Mid(soruMetni, i, 3) = "B)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "B. " Or _
Mid(soruMetni, i, 3) = "B." & Chr(9) Or _
Mid(soruMetni, i, 3) = "B- " Or _
Mid(soruMetni, i, 3) = "B-" & Chr(9) Then
secB = i
Exit For
End If
Next i
For i = secB To Len(soruMetni) - 2
If Mid(soruMetni, i, 3) = "c) " Or _
Mid(soruMetni, i, 3) = "c)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "c. " Or _
Mid(soruMetni, i, 3) = "c." & Chr(9) Or _
Mid(soruMetni, i, 3) = "c- " Or _
Mid(soruMetni, i, 3) = "c-" & Chr(9) Or _
Mid(soruMetni, i, 3) = "C) " Or _
Mid(soruMetni, i, 3) = "C)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "C. " Or _
Mid(soruMetni, i, 3) = "C." & Chr(9) Or _
Mid(soruMetni, i, 3) = "C- " Or _
Mid(soruMetni, i, 3) = "C-" & Chr(9) Then
secC = i
Exit For
End If
Next i
For i = secC To Len(soruMetni) - 2
If Mid(soruMetni, i, 3) = "d) " Or _
Mid(soruMetni, i, 3) = "d)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "d. " Or _
Mid(soruMetni, i, 3) = "d." & Chr(9) Or _
Mid(soruMetni, i, 3) = "d- " Or _
Mid(soruMetni, i, 3) = "d-" & Chr(9) Or _
Mid(soruMetni, i, 3) = "D) " Or _
Mid(soruMetni, i, 3) = "D)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "D. " Or _
Mid(soruMetni, i, 3) = "D." & Chr(9) Or _
Mid(soruMetni, i, 3) = "D- " Or _
Mid(soruMetni, i, 3) = "D-" & Chr(9) Then
secD = i
Exit For
End If
Next i
For i = secD To Len(soruMetni) - 2
If Mid(soruMetni, i, 3) = "e) " Or _
Mid(soruMetni, i, 3) = "e)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "e. " Or _
Mid(soruMetni, i, 3) = "e." & Chr(9) Or _
Mid(soruMetni, i, 3) = "e- " Or _
Mid(soruMetni, i, 3) = "e-" & Chr(9) Or _
Mid(soruMetni, i, 3) = "E) " Or _
Mid(soruMetni, i, 3) = "E)" & Chr(9) Or _
Mid(soruMetni, i, 3) = "E. " Or _
Mid(soruMetni, i, 3) = "E." & Chr(9) Or _
Mid(soruMetni, i, 3) = "E- " Or _
Mid(soruMetni, i, 3) = "E-" & Chr(9) Then
secE = i
Exit For
End If
Next i
For i = secA - 5 To 1 Step -1
If Mid(soruMetni, i, 1) = Chr(13) Then
Enter = i
Exit For
End If
Next i
If Enter <> "" Then
paragraf = Trim(Mid(soruMetni, 1, Enter))
soruKoku = Trim(Mid(soruMetni, Enter + 2, secA - Enter - 2))
Else
paragraf = ""
soruKoku = Trim(Mid(soruMetni, 1, secA - 1))
End If
secenekA = Trim(Mid(soruMetni, secA + 2, secB - secA - 2))
secenekB = Trim(Mid(soruMetni, secB + 2, secC - secB - 2))
secenekC = Trim(Mid(soruMetni, secC + 2, secD - secC - 2))
secenekD = Trim(Mid(soruMetni, secD + 2, secE - secD - 2))
secenekE = Trim(Mid(soruMetni, secE + 2, Len(soruMetni) - secE))
If paragraf <> "" Then
paragraf = WorksheetFunction.Clean(paragraf) 'Clean() yazdırılamayan karakterleri temizler.
paragraf = WorksheetFunction.Trim(paragraf) 'Trim() fazla boşlukları kaldırır.
paragraf = WorksheetFunction.Substitute(paragraf, Chr(173) & " ", "") 'Substitute=Yerinekoy metoduyla, "- " şeklindeki içeriği kaldır
paragraf = WorksheetFunction.Substitute(paragraf, Chr(173), "") 'Substitute=Yerinekoy metoduyla, "-" şeklindeki içeriği kaldır
End If
soruKoku = WorksheetFunction.Clean(soruKoku)
soruKoku = WorksheetFunction.Trim(soruKoku)
soruKoku = WorksheetFunction.Substitute(soruKoku, Chr(173) & " ", "")
soruKoku = WorksheetFunction.Substitute(soruKoku, Chr(173), "")
secenekA = WorksheetFunction.Clean(secenekA)
secenekA = WorksheetFunction.Trim(secenekA)
secenekA = WorksheetFunction.Substitute(secenekA, Chr(173) & " ", "")
secenekA = WorksheetFunction.Substitute(secenekA, Chr(173), "")
secenekB = WorksheetFunction.Clean(secenekB)
secenekB = WorksheetFunction.Trim(secenekB)
secenekB = WorksheetFunction.Substitute(secenekB, Chr(173) & " ", "")
secenekB = WorksheetFunction.Substitute(secenekB, Chr(173), "")
secenekC = WorksheetFunction.Clean(secenekC)
secenekC = WorksheetFunction.Trim(secenekC)
secenekC = WorksheetFunction.Substitute(secenekC, Chr(173) & " ", "")
secenekC = WorksheetFunction.Substitute(secenekC, Chr(173), "")
secenekD = WorksheetFunction.Clean(secenekD)
secenekD = WorksheetFunction.Trim(secenekD)
secenekD = WorksheetFunction.Substitute(secenekD, Chr(173) & " ", "")
secenekD = WorksheetFunction.Substitute(secenekD, Chr(173), "")
secenekE = WorksheetFunction.Clean(secenekE)
secenekE = WorksheetFunction.Trim(secenekE)
secenekE = WorksheetFunction.Substitute(secenekE, Chr(173) & " ", "")
secenekE = WorksheetFunction.Substitute(secenekE, Chr(173), "")
frmSoruEkle.txtParagraf.Text = paragraf
frmSoruEkle.txtSorukoku.Text = soruKoku
frmSoruEkle.txtSecenekA.Text = secenekA
frmSoruEkle.txtSecenekB.Text = secenekB
frmSoruEkle.txtSecenekC.Text = secenekC
frmSoruEkle.txtSecenekD.Text = secenekD
frmSoruEkle.txtSecenekE.Text = secenekE
frmSoruEkle.cmbCevap.SetFocus
Unload Me
Exit Sub
Hata:
MsgBox "Üzgünüm. Bir hata meydana geldi. Bu metni ayrıştıramıyorum.", vbCritical + vbOKOnly, "Hata"
End Sub
Private Sub btnIptal_Click()
Unload Me
End Sub
Private Sub btnKes_Click()
txtSoru.Cut
txtSoru.SetFocus
End Sub
Private Sub btnYapistir_Click()
'Dim hafiza As New MSForms.DataObject
'
'hafiza.GetFromClipboard
'
'txtSoru.SelText = hafiza.GetText
txtSoru.Paste
txtSoru.SetFocus
End Sub
Private Sub txtSoru_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Local Error GoTo bos:
Dim hafiza As New MSForms.DataObject
hafiza.GetFromClipboard
If Len(hafiza.GetText) > 0 Then 'Clipboard nesnesinde text varsa (0'dan büyükse)
CommandBars(menuAdi).Controls(1).Enabled = True 'Yapıştır menüsünü aktifleştir
End If
GoTo atla:
bos:
CommandBars(menuAdi).Controls(1).Enabled = False 'Değilse pasifleştir
atla:
If Len(txtSoru.SelText) = 0 Then 'Seçili metin yoksa
CommandBars(menuAdi).Controls(2).Enabled = False 'Kes menüsünü pasifleştir
Else 'değilse
CommandBars(menuAdi).Controls(2).Enabled = True 'Kes menüsünü aktifleştir
End If
If Button = 2 Then
CommandBars(menuAdi).ShowPopup 'Menüyü göster
End If
End Sub
İyi Çalışmalar.