Döngü ile optik okuyucu sonuçlarını ayrıştırıp altalta dizmek

[cems]

...............G4 Hücresinden başlayan...
ahmet.......DBBCBA......................50 cevap
mehmet.....DADABA
hüseyin.....ADBBAA
arda.........DDDBBA
.
.
40 kişi ( ancak gruba göre 15 kişi ya da 40 kişi arasında değişken )

Şeklinde optik okuyucudan excel'e birleşik olarak ( hepsi bir hücrede ) veri alabiliyorum. Bu birleşik şekliyle daha ince detaya ayıramayacağımdan ( metni sütuna çevir işlemi yardımı ile ) her hücreye bir cevap düşecek şekilde sağa doğru bir sıralama yapıyorum.

Range("G4").Select
[a51:AW100].ClearContents
Application.DisplayAlerts = False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("a51"), DataType:=xlFixedWidth, _

FieldInfo:=Array(Array(0, 2), Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array _
(5, 1), Array(6, 1)........(50 kere array işlemi)
Application.DisplayAlerts = True
End Sub

Ancak bu işi 40 satır/50 cevap için sanırım en iyi yol döngü açmak.
Örnekler basit görünmekle birlikte , ayrılması gereken cevap harflerinin g4 ten başlaması ve altta ilkini ayırdıktan sonra sonraki ayırdığını ilkinin üstüne yazmamasını , bir boş alta geçerek yazmasını başaramadım.

Bu işlemi for-next ya da sizin daha iyi olacağını düşündüğünüz döngü yöntemi ile yapabilmek için nasıl bir döngü yapmak gerekir ?

 

[Necdet]

Merhaba,

Sorunuzu örnek dosya ile destekleyiniz.

 

[cems]

Sayın Necdet Yeşertener ,

Soru ile ilgili örnek ekte sunulmuştur.

Örnekte a ve b gruplarına ayrılmış ve buna göre harmanlanmış soruların , optik okuyucudan excele (birleşik olarak tek bir hücreye) alınabilen cevapları var .

Sorunlar : ( her grup 15 kişiden 40 kişiye kadar değişmekte )
1- Cevapları ( bir kişide sağa doğru 50 cevap olabiliyor ) döngü ile alabilmek
2- Ayrılmış cevapları ayrı bir sayfaya almak . ( ayrı sayfaya almayı geçersiz uygulama olarak durdurdu)

Şimdiden ilginize teşekkür ederim

 

[Necdet]

Merhaba,

Aşağıdaki kodlar, D sütunun E sütunundan başlayarak teker teker ayırır. Umarım doğru anlamışımdır.

Sub AYIR()
Dim i As Long
Dim j As Integer, k As Integer
Application.ScreenUpdating = False
For i = 2 To [B65536].End(3).Row
    k = 4
    For j = 1 To Len(Trim(Cells(i, "D")))
        k = k + 1
        Cells(i, k) = Mid(Trim(Cells(i, "D")), j, 1)
    Next j
    
Next i
Application.ScreenUpdating = True
End Sub

 

[cems]

Sayın Necdet Yeşertener
Doğru ve dahası kökten çözüm oldu kodlarınız ..Benim düşünmediğim ve dağınık olmayan bir şekilde sağa doğru hepsi ayrıştırıldı.
Çok teşekkür ederim , çok sağolun

 

[Necdet]

Güle güle kullanınız.
İyi günler dilerim.

 

[veyselemre]

Necdet Beyin kodlarında Trim fonksiyonlarını RTrim fonksiyonuna çevirin.
Bu şekilde ilk soruya boş cevap verenlerin tüm yanıtları bir kaymış şekilde olur.

 

[Necdet]

Necdet Beyin kodlarında Trim fonksiyonlarını RTrim fonksiyonuna çevirin.
Bu şekilde ilk soruya boş cevap verenlerin tüm yanıtları bir kaymış şekilde olur.

Çok haklısınız Veysel bey, ben onu düşünemedim.

 

[benli58]

sayın cems;
biraz geç oldu. alternatif bir çözüm. kolay gelsin.

 

[alier47]

Ellerinize Sağlık İyi Olmuş