Birden Fazla Sütunu Aynı Anda Satıra Çevirme

[zaffa]

Merhaba Arkadaşlar,
Elimde bir sütunda personel sicilleri, diğer sütunda ad soyadları, sonraki sütunda tarih (ayın başından sonuna kadar), ve son sütunda da hangi şehirde olduğu yazıyor. Amacım Sicil ve ad soyad'ı sabit tutup, bir üst satıra yatay olarak tarihleri yapıştırmak ve her bir tarihin altınada uygun gelen şehiri yapıştırmak.
İf, pivot, vlookup ile denemedim ancak bir türlü sonuca varamadım.
Sadece pivot vasıtası ile sicil, ad soyad ve tarihleri istediğim tablo formatına aldım ancak şehirleri yapıştıramadım.
Ekteki örneği macroyla nasıl yapabilirim acaba?
Yardımlarınız için şimdiden çok teşekkür ederim.

 

[zaffa]

yardımlarınız

 

[apocalyt]

Meraba;
aşağıdaki kodu bir modüle kopyalayın..

Sub daylight()
Application.ScreenUpdating = False
Sheets(2).Range(Cells(2, 1), Cells(1000, 200)).ClearContents
For x = 2 To Sheets(1).[a10000].End(3).Row Step 31
ben = Sheets(2).[a10000].End(3).Row + 1
Sheets(2).Cells(ben, 1) = Sheets(1).Cells(x, 1)
Sheets(2).Cells(ben, 2) = Sheets(1).Cells(x, 2)
Sheets(1).Range("d" & x & ":d" & x + 30).Copy
Sheets(2).Cells(ben, 3).PasteSpecial Transpose:=True
Next x
Application.ScreenUpdating = True
End Sub

 

[zaffa]

Meraba;
aşağıdaki kodu bir modüle kopyalayın..

Sub daylight()
Application.ScreenUpdating = False
Sheets(2).Range(Cells(2, 1), Cells(1000, 200)).ClearContents
For x = 2 To Sheets(1).[a10000].End(3).Row Step 31
ben = Sheets(2).[a10000].End(3).Row + 1
Sheets(2).Cells(ben, 1) = Sheets(1).Cells(x, 1)
Sheets(2).Cells(ben, 2) = Sheets(1).Cells(x, 2)
Sheets(1).Range("d" & x & ":d" & x + 30).Copy
Sheets(2).Cells(ben, 3).PasteSpecial Transpose:=True
Next x
Application.ScreenUpdating = True
End Sub

Öncelikle yardımınız ve ilginiz için çok teşekkür ederim.
Vermiş olduğunuz kodları modüle kopyaladım ancak ekteki hatayı aldım

 

[apocalyt]

rica ederim..ancak ben şimdi gene denedim..hata vermeden çalışıyor..acaba kullandığınız excel sürümüyle ilgili bir sorunmu oluyo..tam anlıyamadım..yani kodda bir hata yok..

 

[zaffa]

rica ederim..ancak ben şimdi gene denedim..hata vermeden çalışıyor..acaba kullandığınız excel sürümüyle ilgili bir sorunmu oluyo..tam anlıyamadım..yani kodda bir hata yok..

Acaba ben işlemi yanlış mı yapıyorum;
Foruma koymuş olduğum excel dosyasını açtıktan sonra ALT+F11 tuşuna basarak Visual Basic'i açıyorum, oradan insert menüsünden module seçeneğini seçip çıkan ekrana sizin vermiş olduğunuz kodu yapıştırıyorum sonrasında continue (devam et) tuşuna tıklıyorum. Gidişatımda bir hata var mı acaba?
(Excel 2010 kullanıyorum)

 

[apocalyt]

şimdi kodu sayfa1 de iken çalıştırdıysanız hata mesajı verebilir..şimdi bende farkettim..ufak bir değişiklik yapalım.umarım olur..koddaki şu satırı

Sheets(2).Range(Cells(2, 1), Cells(1000, 200)).ClearContents

aşağıdakiyle değiştirin..

Sheets(2).Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(1000, 200)).ClearContents

 

[zaffa]

şimdi kodu sayfa1 de iken çalıştırdıysanız hata mesajı verebilir..şimdi bende farkettim..ufak bir değişiklik yapalım.umarım olur..koddaki şu satırı

Sheets(2).Range(Cells(2, 1), Cells(1000, 200)).ClearContents

aşağıdakiyle değiştirin..

Sheets(2).Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(1000, 200)).ClearContents

Çok teşekkür ederim, kod çalıştı
Kusura bakmaz iseniz bir kaç sorum daha olacak;
Satır sayımın kodda belirttiğini a10000 değerinden fazla olması durumunda, örneğin benim satır sayım 50000 ise "a10000" olarka gördüğüm yerleri "a50000" ile değiştireceğim dimi?
İkinci olarak personel numarası ve ad soyad sütunları gibi sabit olacak bir sütun daha var ise yazmış olduğunuz kodda nereyi değiştirmem gerekiyor acaba?

Sub daylight()
Application.ScreenUpdating = False
Sheets(2).Range(Cells(2, 1), Cells(1000, 200)).ClearContents
For x = 2 To Sheets(1).[a10000].End(3).Row Step 31
ben = Sheets(2).[a10000].End(3).Row + 1
Sheets(2).Cells(ben, 1) = Sheets(1).Cells(x, 1)
Sheets(2).Cells(ben, 2) = Sheets(1).Cells(x, 2)
Sheets(1).Range("d" & x & ":d" & x + 30).Copy
Sheets(2).Cells(ben, 3).PasteSpecial Transpose:=True
Next x
Application.ScreenUpdating = True
End Sub

 

[apocalyt]

ilk olarak sizin satır sayınız 50000 ise evet dediğiniz gibi 10000 yazan yerleri 50000 yapın..ikinci olarak ek bir sutun eklemeniz durumunda diyelimki o sabit sutunu c sutununa eklediniz..öncelkikle koddaki
Sheets(2).Cells(ben, 1) = Sheets(1).Cells(x, 1)
Sheets(2).Cells(ben, 2) = Sheets(1).Cells(x, 2)
satırlarının altına
Sheets(2).Cells(ben, 3) = Sheets(1).Cells(x, 3)
satırını eklemeniz gerekiyo..sonrasında c sutununa yeni bir sutun eklediğinizden dolayı "yer" sutunu d sutunundan e sutununa kaymış oldu.bu nedenle koddaki
Sheets(1).Range("d" & x & ":d" & x + 30).Copy
Sheets(2).Cells(ben, 3).PasteSpecial Transpose:=True
bu iki satırı
Sheets(1).Range("e" & x & ":e" & x + 30).Copy
Sheets(2).Cells(ben, 4).PasteSpecial Transpose:=True
şeklinde yapmanız gerekmektedir..unutmadan "olması gereken" sayfasında tarih c sutunundan başlıyodu..oraya yeni sabit sutununuzu koyun..yani tarihler artık d sutunundan başlaması gerekiyo sizinden tahmin edeceğiniz gibi..

 

[zaffa]

For x = 2 To Sheets(1).[a10000].End(3).Row Step 31
satırı ne manaya geliyor acaba? x=2 ?