Dış Kaynaktan Kopyalanan Soruları Alma

K

komando65

Katılım
16 Mayıs 2017
Mesajlar
53
Excel Vers. ve Dili
2013
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 ?

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
Teşekkürler
İyi Çalışmalar.
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Örnek dosyanızı dosya.tc yada dosya.co dan yükleyip link verirseniz. Daha hızlı cevap alırsınız.
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
komando65' Alıntı:
Örnek dosya linki http://s9.dosya.tc/server2/jti50q/Deneme.rar.html
Genişletmek için tıkla ...
Her dafasında bir soru ekleyip al yaptıktan sonra. Yeni soru deyip tekraf soru al ile yeni sorular alınabiliyor.

Ancak demek istediğiniz dış veriden al dedikten sonra oraya text olarak 1 den fazla soru kopyalayayım onlarıda bir defada alsın ise, program yapınız buna müsat değil.

Sebebi de, her soru ekledikten sonra grubunu , zorluğunu ve cevap seçeneklerini belirleyip kaydediyorsunuz.

Birden fazla soruyu bir defada işleme alacak bir yapı yok.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst