Dikey verileri (koşula bağlı) yataya alma

[turkuaz81]

Herkese merhaba,

Ekteki dosyada anlatmaya çalıştığım bir derdim var.
Dikeyde olan verileri , bazı koşullara göre yataya almak istiyorum. KAçıncı ile yapamadım, Formulle veya makro ile yapabilme imkanı varmıdır?

http://s8.dosya.tc/server4/5kedkw/dosya.xlsx.html

 

[Ömer BARAN]

Merhaba.

A sütunundaki verilerin sıralanmış olduğu varsayımıyla aşağıdaki kod'u kullanabilirsiniz.
(B'deki kritere göre dediğiniz kısmı anlamadım, işlem sadece A sütununa göre yapılıyor)
.

[B]Sub YATAYA_AL()[/B]
If Cells(Rows.Count, 4).End(3).Row > 1 Then _
    Range("D2:D" & Cells(Rows.Count, 1).End(3).Row).ClearContents
For sat = 2 To Cells(Rows.Count, 1).End(3).Row
    adet = WorksheetFunction.CountIf(Range("A:A"), Cells(sat, 1))
        For satt = sat To sat + adet - 1
            metin = metin & " " & Cells(satt, 3)
        Next
    Cells(sat, 4) = Mid(metin, 2, Len(metin))
    metin = "": sat = satt - 1
Next: MsgBox "İşlem tamamlandı..", vbInformation, ".:. Ö. BARAN .::."
[B]End Sub[/B]

 

[isteobenim]

Merhaba.

A sütunundaki verilerin sıralanmış olduğu varsayımıyla aşağıdaki kod'u kullanabilirsiniz.
(B'deki kritere göre dediğiniz kısmı anlamadım, işlem sadece A sütununa göre yapılıyor)
.

[B]Sub YATAYA_AL()[/B]
If Cells(Rows.Count, 4).End(3).Row > 1 Then _
    Range("D2:D" & Cells(Rows.Count, 1).End(3).Row).ClearContents
For sat = 2 To Cells(Rows.Count, 1).End(3).Row
    adet = WorksheetFunction.CountIf(Range("A:A"), Cells(sat, 1))
[B]        For satt = sat To sat + adet - 1
            metin = metin & " " & Cells(satt, 3)[/B]
        Next
    Cells(sat, 4) = Mid(metin, 2, Len(metin))
    metin = "": sat = satt - 1
Next: MsgBox "İşlem tamamlandı..", vbInformation, ".:. Ö. BARAN .::."
[B]End Sub[/B]

Merhaba,

Bu işlemi birleştirme yapmadan , ayrı ayrı hücrelere dağıtmak için nasıl bir değişiklik yapmak gerekir,

Teşekkürler,

 

[turkuaz81]

Hocam eline sağlık, bu haliyle de işimi görüyor.
B kolonundaki şart ; küçükten büyüğe olarak sıralayıp yazmasıydı. Yani B kolonundaki sıra yukarıdan aşağıya 20,40,10,30 olsa bile 10,20,30,40 olarak yanyana verileri yazdırmasıydı.

 

[Ömer BARAN]

Tekrar merhaba.

-- A sütunundaki veri grubu için, B sütunundaki değerin küçüklük sırasına göre, C sütunundaki metinleri D sütununda birleştirmek için;
.

[B][COLOR="Blue"]Sub YATAYA_BİRLEŞTİR()[/COLOR][/B]
Set wf = Application.WorksheetFunction
If Cells(Rows.Count, 4).End(3).Row > 1 Then _
Range("D2:D" & Cells(Rows.Count, 1).End(3).Row).ClearContents
For sat = 2 To Cells(Rows.Count, 1).End(3).Row
    adet = WorksheetFunction.CountIf(Range("A:A"), Cells(sat, 1))
        For k = 1 To adet
            metin = metin & " " & Cells(wf.Match(wf.Small(Range("B" & sat & ":B" & sat + _
            adet - 1), k), Range("B" & sat & ":B" & sat + adet - 1), 0) + sat - 1, 3)
        Next
    Cells(sat, 4) = Mid(metin, 2, Len(metin))
    metin = "": sat = sat + adet - 1
Next: MsgBox "İşlem tamamlandı..", vbInformation, ".:. Ö. BARAN .::."
[B][COLOR="blue"]End Sub[/COLOR][/B]

-- Aynı işlemi tek hücrede birleştirme yerine A sütunundaki veri grubunun ilk satırına, D sütunundan itibaren yan yana sütunlara aktarır.
(Tablonuzun sağında, başka verileriniz varsa bunlar silinir)
.

[B][COLOR="Red"]Sub YATAYA_DAĞIT()[/COLOR][/B]
Set wf = Application.WorksheetFunction
If ActiveSheet.UsedRange.Columns.Count > 3 Then _
    Range(Cells(2, "D"), Cells(Cells(Rows.Count, 1).End(3).Row, _
        ActiveSheet.UsedRange.Columns.Count)).ClearContents
For sat = 2 To Cells(Rows.Count, 1).End(3).Row
    adet = WorksheetFunction.CountIf(Range("A:A"), Cells(sat, 1))
        For k = 1 To adet
            Cells(sat, Cells(sat, Columns.Count).End(1).Column + 1) = Cells(wf.Match(wf.Small(Range("B" _
            & sat & ":B" & sat + adet - 1), k), Range("B" & sat & ":B" & sat + adet - 1), 0) + sat - 1, 3)
        Next
    metin = ""
    sat = sat + adet - 1
Next: MsgBox "İşlem tamamlandı..", vbInformation, ".:. Ö. BARAN .::."
[B][COLOR="Red"]End Sub[/COLOR][/B]

 

[turkuaz81]

Hocam süpersin, ikinciyi istemeye utanıyordum :bravo: sen yapmışsın. Eline sağlık teşekkürler.

 

[isteobenim]

Merhaba,

İkincisini ben talep etmiştim

Teşekkürler, Ömer Bey,