Sutun birleştirme

[tahsinanarat]

Sutun başlıklarına göre sutunları tek bir sutunda birleştirip, başlıklarını sol tarafta satır sayısı kadar yazdırmak.
Ekli dosyada sayfa1 de A dan FQ stununa kadar araba markaları, alt satırlarda ise o markaya ait alt gurupları mevcut olup, ben bunları sayfa2 de a sutununa başlıkların, b sutununa ise gurupların listelenmesini istiyorum, tek sutunda birleştirmesini becerebildim, ancak sol tarafa başlıkları yazdıramadım. Örnek dosyam ektedir. Yardımcı olabilecek arkadaşlarıma şimdiden teşekkür ediyorum.

 

[erginozdemir]

Tahsin Bey,

aşağıdaki kodlar sanırım sorunuzun cevabı olacaktır.

iyi günler.

Sub ters_cevir()

Sheets("sayfa1").Select
Range("a1").Select
If ActiveCell.Value = "" Then
    MsgBox "taşınacak öğe yok"
    Exit Sub
End If

For marka = 1 To WorksheetFunction.CountA(Range("a1:ıv1"))
    Sheets("sayfa1").Select
    Cells(1, marka).Copy
    Sheets("sayfa2").Select
    For grup = 1 To WorksheetFunction.CountA(Range(Sheets("sayfa1").Cells(2, marka), Sheets("sayfa1").Cells(65536, marka)))
        Range("a" & WorksheetFunction.CountA(Range("a1:a65536")) + 1).Select
        ActiveSheet.Paste
    Next grup
    
    Range(Sheets("sayfa1").Cells(2, marka), Sheets("sayfa1").Cells(WorksheetFunction.CountA(Range(Sheets("sayfa1").Cells(2, marka), Sheets("sayfa1").Cells(65536, marka))) + 1, marka)).Copy
    
    Range("b" & WorksheetFunction.CountA(Range("b1:b65536")) + 1).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    
    
Next marka

End Sub

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub test2()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:b5000").ClearContents
For i = 1 To [B][COLOR=blue]12[/COLOR][/B]
marka = s1.Cells(1, i).Value
    For sut = 2 To s1.Cells(65536, i).End(3).Row
        sat = s2.[a65536].End(3).Row + 1
        model = s1.Cells(sut, i).Value
        s2.Cells(sat, "a").Value = marka
        s2.Cells(sat, "b").Value = model
    Next sut
Next i
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

Not: 12 sayısını Sayfa1'de veri olan kolon sayısı kadar düzeltiniz.

 

[tahsinanarat]

Sn. erginozdemir ve sn. Recep İpek hocam her ikinize de çok teşekkür ediyorum, alel acele kodları denedim, Recep hocam sizin kodlarınız tam istediğim gibi sonuç verdi, sn. erginozdemir'in kodları ise belli bir satırdan sonra a sutununu boş bıraktı, onu da eve gidince tekrar inceleyeceğim. Her ikinize de saygılarımı sunarım. Teşekkürler.

 

[tahsinanarat]

sn.erginozdemir sizin kodlarınızda gayet güzel çalışıyor, emeğinize sağlık. saygılar.

 

[peleryn]

Kodları ben de uyarladım ve çok işime yarayacak bir çalışmaya denk gelmiş oldum.Ellerinize sağlık.

Bu kodlara ek olarak şöyle birşey rica etsem:

tam tersini yapsak yani sayfa2 deki listeyi sayfa3 e sayfa1 deki gibi dağıtmak istesek kodları nasıl yazmamız gerekir.

 

[Recep İpek]

Son dolu kolona kadar çalışması için yani 12 sayısını yazmamak için aşağıdaki değişikliği yapabilirsiniz.

Sub test2()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:b5000").ClearContents
For i = 1 To [B]s1.[IV3].End(1).Column[/B]
marka = s1.Cells(1, i).Value
    For sut = 2 To s1.Cells(65536, i).End(3).Row
        sat = s2.[a65536].End(3).Row + 1
        model = s1.Cells(sut, i).Value
        s2.Cells(sat, "a").Value = marka
        s2.Cells(sat, "b").Value = model
    Next sut
Next i
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[tahsinanarat]

Sn.l Recep İpek hocam, Sn. Peleryn'in dediği gibi tam tersini de yaptırabilirmiyiz, şu an için lazım değil ancak, olursa arşivimize ekleriz. Yani sayfa2 deki A ve B sutununu ilk haline Sayfa1 deki şekline getirmek için kodlar nasıl olmalıydı. Teşekkürler.

 

[erginozdemir]

sayın peleryn ve tahsin,

aşağıdaki kodlar ters işlemi yapmak için yeterli sanırım.

iyi günler.

Sub ters_cevir_2()
    Sheets("sayfa2").Select
    For marka = 1 To WorksheetFunction.CountA(Range("a1:a65536"))
        Sheets("sayfa2").Select
        Cells(marka, 2).Copy
        Sheets("sayfa3").Select
        Cells(1, WorksheetFunction.CountA(Range("a1:ıv1")) + 1).Select
        If ActiveCell.Offset(1, 0).Value = "" Then
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
        End If
        If ActiveCell.Offset(1, 0).Value <> "" And ActiveCell.Offset(2, 0) = "" Then
            Selection.End(xlDown).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
        End If
        If ActiveCell.Offset(1, 0).Value <> "" And ActiveCell.Offset(2, 0) <> "" Then
            Selection.End(xlDown).Select
            Selection.End(xlDown).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
        End If
        Application.CutCopyMode = False
        Sheets("sayfa2").Select
        If Cells(marka, 1) <> Cells(marka + 1, 1) Then
            Cells(marka, 1).Copy Sheets("sayfa3").Cells(1, WorksheetFunction.CountA(Sheets("sayfa3").Range("a1:ıv1")) + 1)
        End If
    Next marka
End Sub

 

[peleryn]

Sn ergin kodları ancak dosyaya aktarma fırsatım oldu elinize sağlık.son sütunun adını yerleştirme dışında tamamen çalışıyor.Emeğiniz için çok teşekkür ederim.

 

[erginozdemir]

Sayın peleryn,

Daha önceki kodların sonuna aşağıdaki satırı eklerseniz sorun çözülmüş olacaktır.

Cells(WorksheetFunction.CountA(Range("a1:a65536")), 1).Copy Sheets("sayfa3").Cells(1, WorksheetFunction.CountA(Sheets("sayfa3").Range("a1:ıv1")) + 1)

 

[tahsinanarat]

Sn. erginozdemir, ilgi ve alakanıza çok teşekkür ediyorum, çok güzel olmuş, elinize sağlık. Saygılar.

 

[peleryn]

Ergin bey aynen öyle oldu ve gayet güzel oldu ellerinize sağlık teşekkür ederim.