DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Necdet hocam kusuruma bakmayın okuldaki internetten cevap yazamadım imleç döndü durdu.İsimlere göre başka bir sayfada sıralanması olabilir
Sub aktar()
Set s1 = Sheets("hikaye")
Set s2 = Sheets("liste")
sonsat = WorksheetFunction.Max(4, s1.Cells(Rows.Count, "B").End(3).Row)
sonsut = WorksheetFunction.Max(3, s1.Cells(3, Columns.Count).End(xlToLeft).Column)
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
s2.Rows("2:" & eski).ClearContents
yenikişi = 2
For kişi = 4 To sonsat
yenikitap = 2
If WorksheetFunction.CountIf(s1.Range(s1.Cells(kişi, "C"), s1.Cells(kişi, sonsut)), "X") > 0 Then
s2.Cells(yenikişi, "A") = s1.Cells(kişi, "B")
For kitap = 3 To sonsut
If s1.Cells(kişi, kitap) = "X" Then
s2.Cells(yenikişi, yenikitap) = s1.Cells(3, kitap)
yenikitap = yenikitap + 1
End If
Next
yenikişi = yenikişi + 1
End If
Next
End Sub
ilginize teşekkür ederin Necdet HocamMerhaba, ben de işyerindeki internette kısıtlama olduğu için verdiğiniz adrese ulaşıp bakamıyorum![]()
Sub aktar()
Set s1 = Sheets("hikaye")
Set s2 = Sheets("liste")
sonsat = WorksheetFunction.Max(4, s1.Cells(Rows.Count, "B").End(3).Row)
sonsut = WorksheetFunction.Max(3, s1.Cells(3, Columns.Count).End(xlToLeft).Column)
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
s2.Rows("2:" & eski).ClearContents
yenikişi = 2
For kişi = 4 To sonsat
yenikitap = 2
If WorksheetFunction.CountIf(s1.Range(s1.Cells(kişi, "C"), s1.Cells(kişi, sonsut)), "X") > 0 Then
s2.Cells(yenikişi, "A") = s1.Cells(kişi, "B")
For kitap = 3 To sonsut
If [B]UCase([/B]s1.Cells(kişi, kitap)[B])[/B] = "X" Then
s2.Cells(yenikişi, yenikitap) = s1.Cells(3, kitap)
yenikitap = yenikitap + 1
End If
Next
yenikişi = yenikişi + 1
End If
Next
End Sub
Sub Listele()
Dim i As Long, _
j As Long, _
k As Integer, _
m As Integer, _
ShH As Worksheet, _
ShL As Worksheet
Set ShH = Sheets("Hikaye")
Set ShL = Sheets("Liste")
k = ShH.Range("C3").End(xlToRight).Column
j = 1
Application.ScreenUpdating = False
ShL.Range("A2:C" & Rows.Count).ClearContents
For i = 4 To ShH.Cells(Rows.Count, "A").End(3).Row
For m = 3 To k
If Not ShH.Cells(i, m) = "" Then
j = j + 1
ShL.Cells(j, "A") = ShH.Cells(i, "A")
ShL.Cells(j, "B") = ShH.Cells(i, "B")
ShL.Cells(j, "C") = ShH.Cells(3, m)
End If
Next m
Next i
ShL.Range("A2:C" & j).Sort Key1:=ShL.Range("B1"), Key2:=ShL.Range("C1")
Application.ScreenUpdating = True
MsgBox "Aktarım ve Listeleme Tamamlanmıştır...", vbInformation
End Sub