birer satır atlayarak satırları sütun haline getirme

[m.ensar]

Merhaba hayırlı günler örnek olarak eklediğim dosya da çeşitli veriler bulunduran bir tablo var. tablo da a sütunun da 3. hücrede tc 4. hücrede adı soyadı var ve yanyana sütunlarda bu şekil değişik veriler var. istiyorum ki a sütununda sadece tc ler olsun b sütununa adı soyadı olsun bu şekilde tabloda ki satırları sütun haline getirilsin.
örnek dosya da yeşil renkli tablo şeklinde olmasını istiyorum.
iyi çalışmalar hayırlı günler tekrar

 

[ÖmerFaruk]

Sub TabloYenile()
' yeni bir sayfa oluşturun ve adını aşağıdaki YENİ yazan tırnak içine yazın
' Yeni oluşturduğunuz sayfada başlık satırını 1.satırda oluşturun ve
' başlıklarınızı yazın
' yeni tablonuzun verileri 2.satırdan başalayacak şekilde kodlar aşağıdadır
' Bu kodu mevcut sayfa içinde çalıştırabilirsiniz


Set Sh = Worksheets("Yeni")
x = 1
For i = 3 To Range("A3").End(xlDown).Row Step 2
x = x + 1
    For k = 1 To 9
        Sh.Range(x, 2 * k - 1) = Range(i, k)
    Next k
    For k = 1 To 9
        Sh.Range(x, 2 * k) = Range(i + 1, k)
    Next k
Next i
End Sub

 

[m.ensar]

Sh.Range(x, 2 * k - 1) = Range(i, k)
bu satırı hata olarak gösteriyor hocam

 

[ÖmerFaruk]

Tüm Range yazan yerleri Cells olarak değiştirir misin.

 

[m.ensar]

For i = 3 To Range("A3").End(xlDown).Row Step 2
hocam ya ben bişeyleri yanlış yapıyorum yada anlamadım range leri Cells olarak değiştirdiğimde bu satırı hata olarak gösteriyor

 

[m.ensar]

For i = 3 To Cells("A3").End(xlDown).Row Step 2

 

[Korhan Ayhan]

Listedeki değerlerin renkleri yeni listede de olacak mı?

 

[ÖmerFaruk]

Sub TabloYenile()
' yeni bir sayfa oluşturun ve adını aşağıdaki YENİ yazan tırnak içine yazın
' Yeni oluşturduğunuz sayfada başlık satırını 1.satırda oluşturun ve
' başlıklarınızı yazın
' yeni tablonuzun verileri 2.satırdan başalayacak şekilde kodlar aşağıdadır
' Bu kodu mevcut sayfa içinde çalıştırabilirsiniz


Set Sh = Worksheets("Yeni")
x = 1
For i = 3 To Range("A3").End(xlDown).Row Step 2
x = x + 1
    For k = 1 To 9
        Sh.Cells(x, 2 * k - 1) = Cells(i, k)
    Next k
    For k = 1 To 9
        Sh.Cells(x, 2 * k) = Cells(i + 1, k)
    Next k
Next i
End Sub

 

[m.ensar]

Listedeki değerlerin renkleri yeni listede de olacak mı?

yok hocam renk önemli değil sadece sütunlara döksün yeterli

 

[m.ensar]

NextLevel üstadım çok teşekkür ediyorum. emeğinize sağlık şu an test edebildim çok güzel çalışıyor

 

[m.ensar]

bu tablonun aynısında bir de tc ve adı soyadı nı aynı hücreye atamışlar. yani bu listede a3 hücresi tc a4 hücresi adı soyadını içerirken aynı listeyi bir başka arkadaş a3 hücresine tc ve adı soyadını yazmış. onları da sütunlara ayırmak mümkün mü? yaklaşık 2000 kişilik bir tablo her ikiside.

 

[ÖmerFaruk]

Deneyin bakalım olmuş mu

Sub TabloYenile()
' yeni bir sayfa oluşturun ve adını aşağıdaki YENİ yazan tırnak içine yazın
' Yeni oluşturduğunuz sayfada başlık satırını 1.satırda oluşturun ve
' başlıklarınızı yazın
' yeni tablonuzun verileri 2.satırdan başalayacak şekilde kodlar aşağıdadır
' Bu kodu mevcut sayfa içinde çalıştırabilirsiniz

Set Sh = Worksheets("Yeni")
x = 1
For i = 3 To Range("A3").End(xlDown).Row Step 2
x = x + 1
    Tc = Left(Trim(Cells(i, 1)), 11)
    AdSoyad = Trim(cell(i + 1, 1))
    If AdSoyad = "" Then AdSoyad = Trim(Replace(Cells(i, 1), Tc, ""))
    Sh.Cells(x, 1) = Tc
    Sh.Cells(x, 2) = AdSoyad
    For k = 2 To 9
        Sh.Cells(x, 2 * k - 1) = Cells(i, k)
        Sh.Cells(x, 2 * k) = Cells(i + 1, k)
    Next k
Next i
End Sub

 

[m.ensar]

hocam örnek bir tablo atayım aktarma yapıyor ancak misal A3 hücresindeki Tc yi alıyor ismi siliyor bir önceki makronuz gibi A4 hücresini sütuna ekliyor. örnek bir tablo ekliyorum

 

[Korhan Ayhan]

Her iki dosyanızı tek dosya birleştirdim.

Alternatif olarak deneyebilirsiniz.

Hız olarak avantaj sağlayacaktır.

 

[Korhan Ayhan]

#14 nolu mesajımda ki dosyayı her iki dosyanızda ki verileri düzenleyecek şekilde revize ettim. Deneyebilirsiniz.

 

[m.ensar]

hocam emeğinize sağlık harikasınız çok teşekkür ediyorum