IF ile Transpose yapmak

[search77]

Saygı değer arkadaşlar merhaba,

Ekli dosyamda ID KOD adedine göre transpose yapmak istiyorum, dosyada açıklamalarımı belirttim.

Yardımcı olabilecek arkadaşlara şimdiden minnettarım.

Saygı ve sevgilerimle.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Sub Transpose_Aktar()
    Dim X, Say, Satir, Veri
    
    Range("B2:B" & Rows.Count).ClearContents
    ReDim Dizi(1 To 1)
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        Say = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        For Each Veri In Range("C" & X & ":I" & X + Say - 1)
            If Veri <> "" Then
                Satir = Satir + 1
                ReDim Preserve Dizi(1 To Satir)
                Dizi(Satir) = Veri
                If Satir = Say Then Exit For
            End If
        Next
                
        Cells(X, 2).Resize(Say) = Application.Transpose(Dizi)
        Erase Dizi
        X = X + Say - 1
        Satir = 0
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[search77]

Korhan Bey,

Elinize sağlık, mükemmel ötesi olmuş, bu benim çok işimi görücek.

Çok çok teşekkürler.

Saygı ve sevgilerimle.

 

[webuyeislemleri]

Merhaba,

Aşağıdaki kodu denermisiniz.

Sub Transpose_Aktar()
    Dim X, Say, Satir, Veri
    
    Range("B2:B" & Rows.Count).ClearContents
    ReDim Dizi(1 To 1)
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        Say = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        For Each Veri In Range("C" & X & ":I" & X + Say - 1)
            If Veri <> "" Then
                Satir = Satir + 1
                ReDim Preserve Dizi(1 To Satir)
                Dizi(Satir) = Veri
                If Satir = Say Then Exit For
            End If
        Next
                
        Cells(X, 2).Resize(Say) = Application.Transpose(Dizi)
        Erase Dizi
        X = X + Say - 1
        Satir = 0
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

bu konuda nasıl bir yol izleye biliriz, Tşk.
http://www.excel.web.tr/f48/satyrlardan-ko-ullu-tablo-olu-turma-hakkynda-t137871.html#post746749