Sutunları satıra aktarma

[okreg]

Merhabalar,

Ana listede yatayda bulunan ders isimlerini diğer sheette(Dikey liste) yataya atıp
isim okul sınıf ve not bilgisini yan yana aynı hücrede yazdıracak macro koduna ihtiyacım var.

Şimdiden teşekkürler

http://s5.dosya.tc/server/xi9rbd/Ornek.xlsx.html

 

[PLİNT]

Merhaba
Ek dosyayı inceleyiniz.
http://s5.dosya.tc/server/b0o8pb/Xl0000004.zip.html

Private Sub CommandButton1_Click()
Dim s1, s2 As Worksheet
Dim a, b, f As Long
Dim i As Integer
Dim c
Set s1 = Sheets("Ana Liste")
Set s2 = Sheets("Dikey Liste")
s2.Cells = Empty
a = s1.Cells(1, Columns.Count).End(xlToLeft).Column
b = s1.Cells(Rows.Count, 1).End(3).Row
i = 1
For Each x In s1.Range(s1.Cells(1, 4), s1.Cells(1, a))
i = i + 1
s2.Cells(i, 1) = x.Value
Next
For Each c In s1.Range(s1.Cells(2, 4), s1.Cells(b, a))
If c.Value <> "" Then
f = s2.Cells(c.Column - 2, c.Row).End(xlToLeft).Column + 1
s2.Cells(c.Column - 2, f) = s1.Cells(c.Row, 1) & " " & s1.Cells(c.Row, 2) & " " & _
s1.Cells(c.Row, 3) & " " & c.Value
End If
Next
End Sub

 

[okreg]

Merhaba
Ek dosyayı inceleyiniz.
http://s5.dosya.tc/server/b0o8pb/Xl0000004.zip.html

Private Sub CommandButton1_Click()
Dim s1, s2 As Worksheet
Dim a, b, f As Long
Dim i As Integer
Dim c
Set s1 = Sheets("Ana Liste")
Set s2 = Sheets("Dikey Liste")
s2.Cells = Empty
a = s1.Cells(1, Columns.Count).End(xlToLeft).Column
b = s1.Cells(Rows.Count, 1).End(3).Row
i = 1
For Each x In s1.Range(s1.Cells(1, 4), s1.Cells(1, a))
i = i + 1
s2.Cells(i, 1) = x.Value
Next
For Each c In s1.Range(s1.Cells(2, 4), s1.Cells(b, a))
If c.Value <> "" Then
f = s2.Cells(c.Column - 2, c.Row).End(xlToLeft).Column + 1
s2.Cells(c.Column - 2, f) = s1.Cells(c.Row, 1) & " " & s1.Cells(c.Row, 2) & " " & _
s1.Cells(c.Row, 3) & " " & c.Value
End If
Next
End Sub

Çok teşekkür ederim. Beni büyük bir zahmetten kurtardınız.

Komutu çok daha büyük bir tabloya uyguladım çalışıyor gibi görünüyor aktarmayı yapıyor fakat alttaki debug veriyor. Maalesef dosyayı paylaşamam.

Neden olabilir?

f = s2.Cells(c.Column - 2, c.Row).End(xlToLeft).Column + 1

 

[PLİNT]

Merhaba
Kodlardaki;

For Each c In s1.Range(s1.[COLOR="Red"]Cells(2, 4)[/COLOR], s1.Cells(b, a))

"Ana Liste" sayfasında: (örnek dosyanıza göre) " range("D2:H8") " aralığında döngü sağlıyor. Belirttiğiniz hata; kodlarda "cells(2,4)" yerine "cells(2,2)" (range("B2")) gibi bir değişiklik yaptınızsa olabilir. "f=2-2","f=0" gibi durum ortaya çıkar öyle olursada hiç bir aktarma yapmaması gerek.

 

[okreg]

Merhaba
Kodlardaki;

For Each c In s1.Range(s1.[COLOR="Red"]Cells(2, 4)[/COLOR], s1.Cells(b, a))

"Ana Liste" sayfasında: (örnek dosyanıza göre) " range("D2:H8") " aralığında döngü sağlıyor. Belirttiğiniz hata; kodlarda "cells(2,4)" yerine "cells(2,2)" (range("B2")) gibi bir değişiklik yaptınızsa olabilir. "f=2-2","f=0" gibi durum ortaya çıkar öyle olursada hiç bir aktarma yapmaması gerek.

Yok üstat bir değişiklik yapmadım fakat asıl dosyamda IN sütununa kadar data var. Yani 248 sütun ve 517 satır
D2 ile IN517 arasını taramalı

 

[PLİNT]

Yok üstat bir değişiklik yapmadım fakat asıl dosyamda IN sütununa kadar data var. Yani 248 sütun ve 517 satır
D2 ile IN517 arasını taramalı

Merhaba
Kodları "xls" formatındaki dosyasında kullanıyorsanız,
517 satır için en azından 2. sayfada 400 sütun gerekiyor 256 dan sonra hata veriyor, öyle ise dosyanızı "xlsm" olarak kaydedip deneyin
ekte ki (yukarıdaki kodlarla yapılmış) örnek dosyada
300 sütun, 698 satır bulunuyor
http://s2.dosya.tc/server/fyzrvu/Xl0000010.zip.html

 

[okreg]

Merhaba
Kodları "xls" formatındaki dosyasında kullanıyorsanız,
517 satır için en azından 2. sayfada 400 sütun gerekiyor 256 dan sonra hata veriyor, öyle ise dosyanızı "xlsm" olarak kaydedip deneyin
ekte ki (yukarıdaki kodlarla yapılmış) örnek dosyada
300 sütun, 698 satır bulunuyor
http://s2.dosya.tc/server/fyzrvu/Xl0000010.zip.html

Evet xlsm olarak kaydedince hata vermedi.
Çok çok teşekkür ederim

Kolaylıklar dilerim.

 

[PLİNT]

Evet xlsm olarak kaydedince hata vermedi.
Çok çok teşekkür ederim

Kolaylıklar dilerim.

Rica ederim, kolay gelsin.

 

[okreg]

Rica ederim, kolay gelsin.

bir şey daha soracağım

i = 1
For Each x In s1.Range(s1.Cells(4, 14), s1.Cells(4, a))
For Each y In s1.Range(s1.Cells(3, 14), s1.Cells(3, a))
i = i + 1
s2.Cells(i, 1) = x.Value & " " & y.Value
Next
Next

yapmak istediğim sırasıyla
N3&N4
O3&O4
P3&P4
....
IXa&IXa

yazdırmak ama sonsuz döngüye giriyor.

 

[PLİNT]

bir şey daha soracağım

yapmak istediğim sırasıyla
N3&N4
O3&O4
P3&P4
....
IXa&IXa
yazdırmak ama sonsuz döngüye giriyor.

Bu isteğinize göre döngüyü şöyle kurabilirsiniz;

Private Sub CommandButton1_Click()
Dim s1, s2 As Worksheet
Dim a, i As Long
Set s1 = Sheets("Ana Liste")
Set s2 = Sheets("Dikey Liste")
s2.Cells = Empty
a = s1.Cells(3, Columns.Count).End(xlToLeft).Column
For i = 14 To a
s2.Cells(i - 13, 1) = s1.Cells(3, i) & " " & s1.Cells(4, i)
Next
End Sub

http://s4.dosya.tc/server/gpkd6k/Xl0000004.zip.html

 

[okreg]

Bu isteğinize göre döngüyü şöyle kurabilirsiniz;

Teşekkür ederim, elinize sağlık.