• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

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)
.
Kod: 
[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]
 
Ömer BARAN' Alıntı:
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)
.
Kod: 
[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]
Genişletmek için tıkla ...


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,
 
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ı.
 
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;
.
Kod: 
[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)
.
Kod: 
[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]
 
Hocam süpersin, ikinciyi istemeye utanıyordum :bravo: sen yapmışsın. Eline sağlık teşekkürler.
 
Merhaba,

İkincisini ben talep etmiştim:)

Teşekkürler, Ömer Bey,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst