Rakamlara ve Harflere Göre Ayırma?

[saygac]

Arkadaşlar merhaba bir sorum olacak ek-te göndermiş olduğum pdf formatındaki sorular alt alta cevaplarda alt alta ben bunu excelde a1 kısmına soru , b1 kısmına a şıkkı , c1 kısmına b şıkkı olarak nasıl otomatik olarak yaptırabilirim.
Pek excelden anlamadığımdan kolay bir şekilde açılayabilirseniz sevinirim

Saygılarımla.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle bağlayıp deneyebilir misiniz?

Sub Duzelt()
On Error Resume Next
Dim i As Long
Application.ScreenUpdating = False
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = 1 To [A65536].End(3).Row Step 6
    Cells(i, "B") = Cells(i + 1, "A")
    Cells(i, "C") = Cells(i + 2, "A")
    Cells(i, "D") = Cells(i + 3, "A")
    Cells(i, "E") = Cells(i + 4, "A")
    Cells(i, "F") = Cells(i + 5, "A")
    
    Cells(i, "B").Replace What:="A.", Replacement:=""
    Cells(i, "C").Replace What:="B.", Replacement:=""
    Cells(i, "D").Replace What:="C.", Replacement:=""
    Cells(i, "E").Replace What:="D.", Replacement:=""
    Cells(i, "F").Replace What:="E.", Replacement:=""
    
    Cells(i, "B") = Trim(Cells(i, "B"))
    Cells(i, "C") = Trim(Cells(i, "C"))
    Cells(i, "D") = Trim(Cells(i, "D"))
    Cells(i, "E") = Trim(Cells(i, "E"))
    Cells(i, "F") = Trim(Cells(i, "F"))

    Cells(i + 1, "A") = ""
    Cells(i + 2, "A") = ""
    Cells(i + 3, "A") = ""
    Cells(i + 4, "A") = ""
    Cells(i + 5, "A") = ""
    
Next i
    
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
MsgBox "İşlem Tamamdır......."
Application.ScreenUpdating = True
End Sub

 

[saygac]

Dostum çok sağol allah razı olsun sende tam istediğim gibi oluyor ancak bir sıkıntım var onuda çözebilirsek tam olacak bazı sorular uzun örneğin ek-te bulunan dosyadaki 9. soru böyle olunca haliyle excel bir alt satıra sorunun geri kalanı atıyor bunu tek hücrede nasıl yapabilirim yani 9. soru a1 hücresinin tamamında olması gerekiyor tek bir hücrede ?

 

[Necdet]

Merhaba,

Bir deneyin bakalım, umarım olmuştur.

Sub Duzelt()
On Error Resume Next
Dim i As Long
Dim var As Integer
Application.ScreenUpdating = False
'---------- Soru Alt Satıra Kaymış mı Bir Bakalım -----------
For i = [A65536].End(3).Row To 2 Step -1
    var = 99
    var = Application.WorksheetFunction.Find(".", Cells(i, "A"))
    If var > 4 Then
        Cells(i - 1, "A") = Cells(i - 1, "A") & " " & Cells(i, "A")
        Cells(i, "A") = ""
    End If
Next i
'-----------Varsa Kayan Soru,  düzeltildik ----------------

Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = 1 To [A65536].End(3).Row Step 6
    Cells(i, "B") = Cells(i + 1, "A")
    Cells(i, "C") = Cells(i + 2, "A")
    Cells(i, "D") = Cells(i + 3, "A")
    Cells(i, "E") = Cells(i + 4, "A")
    Cells(i, "F") = Cells(i + 5, "A")
    
    Cells(i, "B").Replace What:="A.", Replacement:=""
    Cells(i, "C").Replace What:="B.", Replacement:=""
    Cells(i, "D").Replace What:="C.", Replacement:=""
    Cells(i, "E").Replace What:="D.", Replacement:=""
    Cells(i, "F").Replace What:="E.", Replacement:=""
    
    Cells(i, "B") = Trim(Cells(i, "B"))
    Cells(i, "C") = Trim(Cells(i, "C"))
    Cells(i, "D") = Trim(Cells(i, "D"))
    Cells(i, "E") = Trim(Cells(i, "E"))
    Cells(i, "F") = Trim(Cells(i, "F"))

    Cells(i + 1, "A") = ""
    Cells(i + 2, "A") = ""
    Cells(i + 3, "A") = ""
    Cells(i + 4, "A") = ""
    Cells(i + 5, "A") = ""
    
Next i
    
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
MsgBox "İşlem Tamamdır......."
Application.ScreenUpdating = True
End Sub

 

[saygac]

Çok Teşekkür ederim gerçekten çok yardımcı oldunuz Allah razı olsun.