Sütundaki Verileri Satıra Aktarmak

[olems]

Merhaba bilgisiz olduğum için yardımınıza ihtiyacım var şimdiden teşekkür ederim. Forumda aradım ancak benim içinde bulunduğum soruna dahil bilgileri bulamadım yada ben araştıramadım iyice. Sütundaki Verileri Satıra Aktarmak istiyorum bunu özal yapıştırma seçenekleri ile yapıyorum fakat çok zor oluyor benim için vakit kaybı oluyor. elimde tek sütunda yaklaşık 60bin adet girdi var bunları belli aralıklarla satırla dönüştürmek istiyorum. Bütün veriler A sütununda ve bunları 7şer aralıklarla satırlara çevirmem lazım resimde olduğu gibi bunun kısa yolu formülü varmıdır?

http://i.hizliresim.com/njZZPN.png

inşallah vardır bir formülü..

 

[vardar07]

Merhaba. öncelikle hoş geldiniz. Forumdan daha iyi yardım alabilmek için örnek dosyanızı eklerseniz size sağlıklı cevap verebilmek için dosya hazırlamak zorunda kalmayalım ki zaman kaybetmeyelim. Dosya yükleme için imza bölümünü okuyun.

 

[Ömer BARAN]

Merhaba, foruma hoşgeldiniz.

Belgenizde, Sayfa1'in (verilerin bulunduğu sayfa) yanısıra Sayfa2 isimli bir sayfa olsun (sonuçların yazılacağı sayfa).

Ekran görüntüsünden anladığım kadarıyla;
aşağıdaki işlem adımlarını sırasıyla uygularsanız istediğiniz sonuca ulaşılması gerekir.

Eğer sonuç alamazsanız, cevabımın aytındaki İMZA bölümünde yer alan açıklamalar doğrultusunda örnek belge ekliyiniz.

-- Alt taraftan Sayfa2 adına fareyle sğ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- açılan VBA ekranında, sağ taraftaki boş alana aşağıdaki kod'u yapıştırın,
-- İmleç, Sub ve End Sub satırları arasında iken F5 tuşuna basın.
.

[FONT="Arial Narrow"][B]Sub SORU_CEVAP()[/B]
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2"): Set wf = Application.WorksheetFunction
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
[COLOR="red"]For satır = 1 To s1.[A65536].End(3).Row
    If s1.Cells(satır, "A") = "" Then s1.Cells(satır, 1) = wf.Max(s1.Range("A1:A" & satır)) + 1
Next[/COLOR]
For soru = 1 To wf.Max(s1.[A:A])
    silk = wf.Match(soru, s1.[A:A], 0) + 1
    If soru = wf.Max(s1.[A:A]) Then
        sson = s1.[A65536].End(3).Row
    Else
        sson = wf.Match(soru + 1, s1.[A:A], 0) - 1
    End If
    sat = s2.[A65536].End(3).Row + 1
    s2.Cells(sat, 1) = soru
    s1.Range(s1.Cells(silk, 1), s1.Cells(sson, 1)).Copy
    s2.Cells(sat, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
[COLOR="red"]    s1.Cells(silk - 1, 1) = ""[/COLOR]
Next
[COLOR="Red"]s2.Activate: [/COLOR]s2.[A1].Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem Tamamlandı...", vbInformation, "..:: O.BARAN ::.."
[B]End Sub[/B][/FONT]

 

[olems]

Öncelikle yardımlarınız için çok çok teşekkür ederim.

vardar07 dosyayı imzandaki gibi yükledim linki aşağıdadır.

http://s9.dosya.tc/server2/okt8ly/ornek.xlsx.html

Ömer BARAN belirttiğin şekilde işlemi yaptım ve hata aldım ekran görüntüsü alıp burda paylaşıyorum

http://i.hizliresim.com/GPaLnV.png

 

[Ömer BARAN]

Önceki cevabımda küçük bir ilave yaptım.
Sayfayı yenileyerek kontrol edin.
Eklenen kısımları kırmızı renklendirdim.

 

[olems]

Nekadar teşekkür etsem az beni büyük bir zaman kaybından kurtardın tüm yardınlarınız için çok teşekkür ederim allah razı olsun. Vermiş olduğun kod çalıştı

 

[Ömer BARAN]

Cümlemizden!...

Kolay gelsin.
.

 

[olems]

İyi akşamlar tekrardan başım sıkıştı daha önce kod bunsefer çalışmadı kensi başıma denedim denedim yapamadım vermiş olduğun kodlarla oynadım ama anlamadığım için çıkaramadım bir türlü aynı sıralama aynı olay tek fark aralarda sayı yerine boşluk var denedim denim bir türlü bir önceki gibi olmadı

http://i.hizliresim.com/r6rLMM.jpg

http://s9.dosya.tc/server2/pisllk/deneme.xlsx.html

 

[Ömer BARAN]

Merhaba.

Önceki cevabımda verdiğim kod'u güncelledim.
Sayfayı yenileyerek kontrol ediniz.

 

[olems]

Çok teşekkür ederim ☺

 

[Ömer BARAN]

Çok teşekkür ederim ☺

Kolay gelsin.
.