sütün başlığındaki değere göre 2. sayfaya 1.satıra sütun ismi yazılacak

[86126]

arkadaşlar örneğim ektedir. sütunun değerine göre 2 sayfada sütun başlığını nasıl yazdırabilirim. yardımlarınızı bekliyorum.

 

[Necdet]

Merhaba,

Hepsi tek bir hücreye yazılacaksa aşağıdaki kodlar kullanılabilir.

Sub BaslıkYaz()
Dim i As Long
Set sr = Sheets("RAPOR")
Set ss = Sheets("Sayfa1")
ss.Select
[A2] = ""
For Each Hücre In sr.UsedRange
    If Hücre.Value = 1 Then
        If [A2] = "" Then
            [A2] = sr.Cells(1, Hücre.Column)
        Else
            [A2] = [A2] & ", " & sr.Cells(1, Hücre.Column)
        End If
    End If
Next Hücre
End Sub

 

[86126]

her satırı ayrı ayrı dğerlendirmem gerekiyor. her satırın değerlerine göre aşağıya doğru sıralaması gerekiyor. ilginiz için teşekkür ederim

 

[86126]

arkadaşlar yardım edecek yokmu mümkünse formülle yapmak istiyorum

 

[Necdet]

Merhaba,

Bir de aşağıdaki şekilde kullanınız. Formülle çözüm beni aşıyor.

Sub BaslıkYaz()
Dim i, Sat As Long
Dim j, Kol As Integer
Dim Deg As String
Set sr = Sheets("RAPOR")
Set ss = Sheets("Sayfa1")
j = 1
sr.Select
Kol = Selection.SpecialCells(xlCellTypeLastCell).Column
Sat = Selection.SpecialCells(xlCellTypeLastCell).Row
ss.Range("A2:A65536").ClearContents
Application.ScreenUpdating = False
For i = 2 To Sat
    Deg = ""
    For Each Hücre In sr.Range(Cells(i, "A"), Cells(i, Kol))
        If Hücre.Value = 1 Then
            If Deg = "" Then
                Deg = sr.Cells(1, Hücre.Column)
            Else
                Deg = Deg & ", " & sr.Cells(1, Hücre.Column)
            End If
        End If
    Next Hücre
    
    If Deg <> "" Then
        j = j + 1
        ss.Cells(j, "A") = Deg
    End If
Next i
ss.Select
Application.ScreenUpdating = True
End Sub

 

[86126]

Beynine sağlık arkadaşım. Bir ricam daha olacak, macroyu çalıştırdığımda boş hücreleri kaydırarak aktarıyor. bulunduğu satıra göre aktarmasını nasıl sağlarız verilerle aynı hizaya gelmiyor. ayrıca rapor sayfasında 2 değerlerinide kapsamasını istiyorum. yeni belgemi ekledim. buna göre yapabilirsen zahmet vermiş olucam.

 

[Necdet]

Merhaba,

Umarım doğru anlamışımdır. Herhangi bir kontrol yapmadım. Rapor sayfası ile Sayfa1 in satırları aynı diye düşündüm.

Sub Bul()
Dim i As Long
Dim j As Integer
Dim Kural As String
Set sr = Sheets("RAPOR")
Set ss = Sheets("Sayfa1")
Application.ScreenUpdating = False
ss.Range("N3:N65000").ClearContents
For i = 2 To sr.[A65536].End(3).Row
    
    Kural = ""
    For j = 18 To 123
        If sr.Cells(i, j) = 1 Then
            If Kural = "" Then
                Kural = sr.Cells(1, j)
            Else
                Kural = Kural & "," & Cells(1, j)
            End If
        End If
    Next j
    
    If Kural <> "" Then ss.Cells(i + 1, "N") = Kural
    
Next i
Application.ScreenUpdating = True
MsgBox "İhlal Edilen Kurallar Bulunup, Aktarıldı", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[86126]

Eline sağlık tam istediğim gibi ancak bir hata var iki kusur vermiyor. virgül geliyor ancak değeri yazmyor. teşekkür ederim ilginize. ikinci ve devamı kusurlarıda yazarsa çok süper olacak

 

[Necdet]

Evet küçük bir hata yapmışım o yüzden ikinci ve diğerleri gelmiyormuş.

Koyu kırmızı olarak yazdığım şey unuttuğum tanımlama.

Sub Bul()
Dim i As Long
Dim j As Integer
Dim Kural As String
Set sr = Sheets("RAPOR")
Set ss = Sheets("Sayfa1")
Application.ScreenUpdating = False
ss.Range("N3:N65000").ClearContents
For i = 2 To sr.[A65536].End(3).Row
 
    Kural = ""
    For j = 18 To 123
        If sr.Cells(i, j) = 1 Then
            If Kural = "" Then
                Kural = sr.Cells(1, j)
            Else
                Kural = Kural & "," & [B][COLOR=red]sr.[/COLOR][/B]Cells(1, j)
            End If
        End If
    Next j
 
    If Kural <> "" Then ss.Cells(i + 1, "N") = Kural
 
Next i
Application.ScreenUpdating = True
MsgBox "İhlal Edilen Kurallar Bulunup, Aktarıldı", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[86126]

eline, beynine sağlık çok teşekkür ederim. tam istediğim gibi olmuş.

 

[86126]

eline beynine sağlık çok teşekkür ederim.