• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Aynı sütunda bulunan soru ve cevapları yatay şekilde sıralama

S

seiko_006

Katılım
19 Kasım 2012
Mesajlar
38
Excel Vers. ve Dili
2007/2013
Türkçe
Merhaba arkadaşlar,

Elimde 5000 kullanıcının cevap vermiş olduğu bir anket bulunmaktadır. Bu ankette her kullanıcı için sorular tek sütunda altalta cevapları karşısındaki sütunda altalta sıralanmış durumdadır.
bunları her kullanıcının verdiği cevapları tek satırda sütün sütün göstermek istiyorum. Nasıl yapabilirim.

Bazı kullanıcılar bazı sorulara cevap vermediği için bu soruların cevapları null olarak geçilmesi gerekiyor ayrıca bazı kullanıcılar bir soruya birden çok seçenek işaretlemiş durumda bu soruya ilişkin sütüna da bu cevapların tek sütün halinde arasında virgül olarak konması gerekiyor.

Yardımlarınızı bekliyorum.

Şimdiden teşekkür ederim.

Örnek dosya linki : https://yadi.sk/i/3dJqYyepsKzGn


https://yadi.sk/i/3dJqYyepsKzGn
 
Aşağıdaki kod işinize yarar umarım.
Kod: 
Sub a()
Set s1 = Sheets("cevaplar")
Set s2 = Sheets("rapor")
Top = s1.Range("A65536").End(3).Row
ilk = 2
For i = 2 To Top
top1 = s2.Range("A65536").End(3).Row + 1
If s1.Range("A" & i + 1) <> s1.Range("A" & i) Then
son = i
s1.Range("A" & ilk & ":" & "C" & ilk).Copy s2.Range("A" & top1)
s1.Range("E" & ilk & ":" & "E" & son).Copy
s2.Range("D" & top1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
ilk = i + 1
End If
Next
End Sub
 
Son düzenleme:
ali cimri bey

maalesef işe yaramadı, yanyana sütünları oluşturuyor, ancak bazı sorulara kullanıcılar cevap vermediği için sütün kayması oluşuyor, o cevap vermediği sütünların null geçmesi gerekiyor ayrıca bir bir soruya birden çok cevap verdiği zaman o soruya ilişkin sütuna cevapları virgül ile ayrılmış şekilde gelmesi istiyorum. yardımlarınızı bekliyorum.

teşekkürler
 
ilk önce bu kodu çalıştırın sonra yukardaki kodu çalıştırın. fazla cevapları teke indiriyor. diğer konu (verilmeyen cevaplar) üzerinde bir şeyler yapmaya çalışacağım.
Kod: 
Sub b()
Set s1 = Sheets("cevaplar")
Top = s1.Range("A65536").End(3).Row
For i = Top To 2 Step -1
If s1.Range("D" & i) = s1.Range("D" & i - 1) Then
s1.Range("E" & i - 1).Value = s1.Range("E" & i - 1).Value & ", " & Range("E" & i)
 s1.Rows(i).Delete Shift:=xlUp
End If
Next
End Sub
 
ali cimri bey

ikinci makro çalışmadı acaba bir sorun mu var
 
hocam ikincisi de çalıştı ben yanlış koymuşum.. verilmeyen cevaplar işini de halledersem benim için çok iyi olacak, sizden haber bekliyorum..
 
alicimri bey,

verilmeyen cevaplar için acaba rapor sekmesinde 26 soru bulunmaktadır. bu her kullanıcı için geçerli acaba rapor sekmesinde 26 soru için cevaplar sekmesinde bulunan her kullanıcı için bu soruların kontrolu yapılabilir mi? şayet o soru yok ise o değere null olarak geçebilir mi?
 
Biraz karışık oldu ama çalışıyor.
Kodları sırası ile çalıştırın.
Yalnız nedenini anlamadığım şekilde örnek dosyanızda ABX1 ve ABX3 ait soruyu doğru olarak görüyor
Kod: 
BU FORMDA YER ALAN BİLGİLERİN BANA AİT OLDUĞUNU VE DOĞRULUĞUNU ONAYLIYORUM.
ABX2 ait
Kod: 
BU FORMDA YER ALAN BİLGİLERİN BANA AİT OLDUĞUNU VE DOĞRULUĞUNU ONAYLIYORUM.
farklı görüyor, tabii yanlış işlem yapıyor. ABX1 ait soruyu ABX2 kopyalayıp yapıştırdığımda düzeliyor.

Kod: 
Sub a()
Set s1 = Sheets("cevaplar")
Top = s1.Range("A65536").End(3).Row
For i = Top To 2 Step -1
If s1.Range("D" & i) = s1.Range("D" & i - 1) Then
s1.Range("E" & i - 1).Value = s1.Range("E" & i - 1).Value & ", " & Range("E" & i)
 s1.Rows(i).Delete Shift:=xlUp
End If
Next
End Sub
Sub b()
Set s1 = Sheets("cevaplar")
Set s2 = Sheets("rapor")
  s1.Rows("1:1").Delete Shift:=xlUp
For E = 4 To 29
bas = bas & "#" & s2.Cells(2, E)
Next
bas = Split(bas, "#")
say = Application.CountIf(s1.Columns("D"), "TC KİMLİK NUMARASI") * UBound(bas)
For j = 1 To say
ax = j Mod 26
If ax = 0 Then ax = 26
If bas(ax) <>Trim(s1.Cells(j, 4))Then
 s1.Range("F1:J1").Copy
s1.Range("A" & j & ":E" & j).Insert Shift:=xlDown
s1.Cells(j, 4).Value = bas(ax)
s1.Range("A" & j - 1 & ":C" & j - 1).Copy s1.Range("A" & j & ":C" & j)
End If
Next
End Sub
Sub c()
Set s1 = Sheets("cevaplar")
Set s2 = Sheets("rapor")
Top = s1.Range("A65536").End(3).Row
ilk = 1
For i = 1 To Top
top1 = s2.Range("A65536").End(3).Row + 1
If s1.Range("A" & i + 1) <> s1.Range("A" & i) Then
son = i
s1.Range("A" & ilk & ":" & "C" & ilk).Copy s2.Range("A" & top1)
s1.Range("E" & ilk & ":" & "E" & son).Copy
s2.Range("D" & top1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
ilk = i + 1
End If
Next
End Sub
 
Son düzenleme:
Yukardaki kodları revize ettim. Uyarıyı dikkate almayın.
 
alicimri bey

ilk sırasıyla bütün kodlarımı çalıştıracağım yoksa en son gönderdiğinizi mi sadece?
 
kodları sırayla mı çalıştıracağım yoksa son gönderdiğinizi mi sadecce çalıştıracağım.
 
Makroyu teke düşürdüm. rapor.xls dosyasındaki sayfaların formatını bozmazsanız makro normal çalışır. Ben defalarca denedim.
Kod: 
Sub a()
Set s1 = Sheets("cevaplar")
Set s2 = Sheets("rapor")
Top = s1.Range("A65536").End(3).Row
For i = Top To 2 Step -1
If s1.Range("D" & i) = s1.Range("D" & i - 1) Then
s1.Range("E" & i - 1).Value = s1.Range("E" & i - 1).Value & ", " & Range("E" & i)
 s1.Rows(i).Delete Shift:=xlUp
End If
Next
 s1.Rows("1:1").Delete Shift:=xlUp
For E = 4 To 29
bas = bas & "#" & s2.Cells(2, E)
Next
bas = Split(bas, "#")
say = Application.CountIf(s1.Columns("D"), "TC KİMLİK NUMARASI") * UBound(bas)
For j = 1 To say
ax = j Mod 26
If ax = 0 Then ax = 26
If bas(ax) <> Trim(s1.Cells(j, 4)) Then
 s1.Range("F1:J1").Copy
s1.Range("A" & j & ":E" & j).Insert Shift:=xlDown
s1.Cells(j, 4).Value = bas(ax)
s1.Range("A" & j - 1 & ":C" & j - 1).Copy s1.Range("A" & j & ":C" & j)
End If
Next
Top = s1.Range("A65536").End(3).Row
ilk = 1
For i = 1 To Top
top1 = s2.Range("A65536").End(3).Row + 1
If s1.Range("A" & i + 1) <> s1.Range("A" & i) Then
son = i
s1.Range("A" & ilk & ":" & "C" & ilk).Copy s2.Range("A" & top1)
s1.Range("E" & ilk & ":" & "E" & son).Copy
s2.Range("D" & top1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
ilk = i + 1
End If
Next
End Sub
 
alicimri bey

Alicimri bey.

Sayenizde bu konuya hallettim. Size çok teşekkür ederim. Şu ramazan gününde Allah sizden razı olsun.

Allah a emanet olun. Tekrar çok teşekkür ederim.

İyi günler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst