Çözüldü Her satırın altına yeni satırlar açıp, belli hücreleri kopyalama

[ttb]

Merhaba,
Herkese iyi pazarlar ve yardımcı geçeceklere şimdiden teşekkürler.
Elimde 10 sütundan oluşan bir tablo var. Bu tablonun G, H, I sütunlarında yer alan verilerin yan yana değil alt alta olması gerekiyor. Yani her satırın altına iki satır daha açılmalı, ilgili satırdaki H ve I hücreleri G hücresinin altına taşınmalı. Geri kalan A, B, C, D, E, F ve J sütunları ise değişmeden kendi satırlarının altına kopyalanmalı.
Bunun, tek tek satır ekleyip copy-paste yapmaktan daha kolay bir yolu var mıdır? Tablom yüzlerce satırdan oluştuğu için günler sürer ve manuel copy-paste hataya da açık olur. Rica etsem bana bu konuda destek olabilir misiniz?
Ekte bir örnek tablo mevcut. İlk sheette elimdeki tablo, ikinci sheette ise ilgili işlem yapıldıktan sonra ne şekilde gözükeceği yer alıyor.
Tekrar teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Public Sub Duzenle()

Dim arr1 As Variant, _
    arr2 As Variant, _
    i    As Long, _
    j    As Long, _
    k    As Integer, _
    Bsk  As Variant

Bsk = Array("", "Ad", "Soyad", "İl", "İlçe", "Mahelle", "Cadde", "Adres", "Kapı No")


arr1 = Sayfa1.Range("A1").CurrentRegion.Value
i = (UBound(arr1, 1) - 1) * 3 + 1

ReDim arr2(1 To i, 1 To 8)
For i = 1 To UBound(arr2, 2)
    arr2(1, i) = Bsk(i)
Next i

j = 2

For i = 2 To UBound(arr1, 1)
    For k = 1 To 7
        arr2(j, k) = arr1(i, k)
        arr2(j + 1, k) = arr1(i, k)
        arr2(j + 2, k) = arr1(i, k)
    Next k
    arr2(j, 8) = arr1(i, 10)
    j = j + 1
    arr2(j, 7) = arr1(i, 8)
    j = j + 1
    arr2(j, 7) = arr1(i, 9)
    j = j + 1
Next i

'Kodların Doğru Çalıştığından Emin Olduğunda Sayfa3'ü Sayfa1 OLARAK DEĞİŞTİRİN
Sayfa3.Range("A1").CurrentRegion.ClearContents
Sayfa3.Range("A1").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2

CreateObject("WScript.Shell").Popup "İŞLEM TAMAMDIR.....", 2

End Sub

 

[ttb]

Çok teşekkür ederim.
Runtime Error 424 şeklinde bir hata verdi ve aşağıdaki satırı sarıya boyadı:

arr1 = Sayfa1.Range("A1").CurrentRegion.Value

 

[Necdet]

Merhaba,
Ben sizin örnek dosyanızdaki gibi kodladım.
Sayfa1 olarak yazdığım kod sayfa adı, bu sizini "MEVCUT TABLO" olarak adlandırdığınız sayfanın indisi.
siz Sayfa1 yerine Sheets("Sayfaadı") olarak ta kullanabilirsiniz, ya da sizin orijinal dosyanızda ne ise onu kullanabilirsiniz.

Veri hazırlandıktan sonra sizin örnek dosyanızda "İSTENEN TABLO" sayfasının kod sayfa adı da Sayfa3. Kod büyük olasılıkla burada da hata verecek.

Bunu da dikkate almanız gerekecek, kodu kendinize göre uyarlayın.
Son durumu sayfa üzerinde gerçekleştirmedim, "İSTENEN TABLO" sayfasına yazdırdım.
Eğer sonuçlar sizi tatmin ederse kodun sonunda belirtilen Sayfa3 olayını yine kendinize uyarlarsınız.

 

[ttb]

Merhaba,
Ben sizin örnek dosyanızdaki gibi kodladım.
Sayfa1 olarak yazdığım kod sayfa adı, bu sizini "MEVCUT TABLO" olarak adlandırdığınız sayfanın indisi.
siz Sayfa1 yerine Sheets("Sayfaadı") olarak ta kullanabilirsiniz, ya da sizin orijinal dosyanızda ne ise onu kullanabilirsiniz.

Veri hazırlandıktan sonra sizin örnek dosyanızda "İSTENEN TABLO" sayfasının kod sayfa adı da Sayfa3. Kod büyük olasılıkla burada da hata verecek.

Bunu da dikkate almanız gerekecek, kodu kendinize göre uyarlayın.
Son durumu sayfa üzerinde gerçekleştirmedim, "İSTENEN TABLO" sayfasına yazdırdım.
Eğer sonuçlar sizi tatmin ederse kodun sonunda belirtilen Sayfa3 olayını yine kendinize uyarlarsınız.

Şimdi anladım ve yapabildim. Tekrar teşekkür ederim.

 

[Necdet]

Güle güle kullanın, sizin verilerinizde hızı merak ettim

 

[ttb]

Sanıyorum 2-3 saniye kadar sürdü.

 

[Necdet]

Kaç satırlık veride bu süre oldu?

 

[ttb]

700 küsur satır