Satır - Sütun Birleştirme

[OOzLeMM]

Merhaba,

Satır ve sütunlarla ilgili bir birleştirme işlemi yapmak istiyorum. Yalnız aynı değer için karşılığında farklı değerler var, bunları sütun sütun ayırmak istiyorum. Ekteki dosyada belirttim, yardımcı olabilirseniz gerçekten çok sevinirim.

 

[Ferhat Pazarçevirdi]

Aşağıdaki gibi bir kod kullanabilirsiniz.

Option Explicit
Sub Satir_Sutun_Birlestir()
Dim col As New Collection
Dim i As Integer, j As Integer
Dim son As Integer
Dim bul As Range
Dim adres As String
Dim sutun As Integer
Sheets("Sheet2").Range("A3:D5000").ClearContents
On Error Resume Next
For i = 3 To Cells(65536, 1).End(xlUp).Row
    col.Add Cells(i, 1), Cells(i, 1)
Next i
On Error GoTo 0
For i = 1 To col.Count
    son = Sheets("Sheet2").Cells(65536, 1).End(xlUp).Row + 1
    Set bul = Columns(1).Find(col.Item(i))
    If Not bul Is Nothing Then
        adres = bul.Address
        Do
            For j = 1 To 3
                If bul.Offset(0, 1) = Sheets("Sheet2").Cells(2, j + 1) Then: sutun = j + 1
            Next
            On Error Resume Next
            With Sheets("Sheet2")
                .Cells(son, 1) = bul.Value
                .Cells(son, sutun) = bul.Offset(0, 2).Value
            End With
            sutun = 0
            Set bul = Columns(1).FindNext(bul)
        Loop While Not bul Is Nothing And bul.Address <> adres
    End If
Next i
Sheets("Sheet2").Select
Set bul = Nothing
End Sub

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.