Sütundaki değerleri satırda birleştirme Mak.

[gertt]

Merhaba.
E7:J15 aralığında bulunan A harfinin D sütunundaki karşılığının M sütununa yazılmasını kodla nasıl sağlayabiliriz?
Örnek bir dosya ekledim.
Teşekkürler...

 

[Mustafa MUTLU]

Buyurun...
Umarım istediğiniz gibi olmuştur..

 

[gertt]

Mustafa Bey, çok teşekkür ederim.Zahmet verdim.Kolay gelsin...
Hayırlı günler dilerim...

 

[Mustafa MUTLU]

Mustafa Bey, çok teşekkür ederim.Zahmet verdim.Kolay gelsin...
Hayırlı günler dilerim...

Rica Ederim..

 

[gertt]

Tekrar merhaba.
Mustafa Bey'in yazmış olduğu kod gerçekten güzel çalışıyor. Ellerine sağlık. Ancak satır ve sütun sayısı arttıkça kodlamada artıyor.Acaba bu kodlama daha kısa bir şekilde yazılabilir mi?

 

[Necdet]

Merhaba,

Deneyiniz.

Sub Yatay()
 
    Dim Sat As Long, _
        i   As Long, _
        j   As Integer, _
        k   As Integer, _
        Hcr As Range
    
    Application.ScreenUpdating = False
    On Error Resume Next
    i = Cells(Rows.Count, "M").End(3).Row
    If i < 7 Then i = 7
    Range("M7:M" & i).ClearContents
    
    j = Range("E6").End(xlToRight).Column
    i = Cells(Rows.Count, "D").End(3).Row
    
    For k = 5 To j
        Sat = k + 2
        For Each Hcr In Range(Cells(7, k), Cells(i, k)).SpecialCells(xlCellTypeConstants, 23)
            If Not Cells(Sat, "M") = "" Then
                Cells(Sat, "M") = Cells(Sat, "M") & ", " & Cells(Hcr.Row, "D")
            Else
                Cells(Sat, "M") = Cells(Hcr.Row, "D")
            End If
        Next Hcr
    Next k
    Application.ScreenUpdating = True
    MsgBox "İşlem TAMAMLANMIŞTIR", vbInformation, "Necdet YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

 

[gertt]

Necdet Bey elinize sağlık, çok güzel olmuş.
Teşekkürler...

 

[Necdet]

Necdet Bey elinize sağlık, çok güzel olmuş.
Teşekkürler...

Güle güle kullanınız.

 

[gertt]

SAYIN Nected Bey, aralarda başka harf varsa sadece a harfinin bulunduğu yerleri dikkate almasını nasıl sağlayabiliriz?
Teşekkürler.

 

[Necdet]

SAYIN Nected Bey, aralarda başka harf varsa sadece a harfinin bulunduğu yerleri dikkate almasını nasıl sağlayabiliriz?
Teşekkürler.

Merhaba,

Kırmızı olan satırlar koda eklenmiştir.

Sub Yatay()
 
    Dim Sat As Long, _
        i   As Long, _
        j   As Integer, _
        k   As Integer, _
        Hcr As Range
    
    Application.ScreenUpdating = False
    On Error Resume Next
    i = Cells(Rows.Count, "M").End(3).Row
    If i < 7 Then i = 7
    Range("M7:M" & i).ClearContents
    
    j = Range("E6").End(xlToRight).Column
    i = Cells(Rows.Count, "D").End(3).Row
    
    For k = 5 To j
        Sat = k + 2
        For Each Hcr In Range(Cells(7, k), Cells(i, k)).SpecialCells(xlCellTypeConstants, 23)
           [COLOR=red] If UCase(Hcr) = "A" Then
[/COLOR]                If Not Cells(Sat, "M") = "" Then
                    Cells(Sat, "M") = Cells(Sat, "M") & ", " & Cells(Hcr.Row, "D")
                Else
                    Cells(Sat, "M") = Cells(Hcr.Row, "D")
                End If
            [COLOR=red]End If
[/COLOR]        Next Hcr
    Next k
    Application.ScreenUpdating = True
    MsgBox "İşlem TAMAMLANMIŞTIR", vbInformation, "Necdet YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

 

[gertt]

Necdet Bey, çok çok teşekkürler...
Kolay gelsin..