Soru Listview de renkli satırları üste alma

[sirkülasyon]

Hayırlı İftarlar

Mevcut kod

Dim i As Integer
Dim LastRow As Integer
Dim ListViewItem As Object
Dim ListViewColumnD As Range
LastRow = Sheets("Puantaj").Cells(Sheets("Puantaj").Rows.Count, "D").End(xlUp).row
For i = 1 To ListView1.ListItems.Count
Set ListViewItem = ListView1.ListItems(i)
Set ListViewColumnD = Sheets("Puantaj").Range("D7:D" & LastRow).Find(ListViewItem.ListSubItems(1).Text)
If Not ListViewColumnD Is Nothing Then
ListViewItem.ForeColor = RGB(255, 0, 0) ' Kırmızı renk
End If
Next i

Listview1 de
ListViewItem.ListSubItems(0).Text
ListViewItem.ListSubItems(1).Text
şeklinde iki tane sütunum var.
ListViewItem.ListSubItems(0).Text olan sütun
ListViewItem.ForeColor = RGB(255, 0, 0) ile renklendirildi.
Sizlerden ricam renklendirilmiş olan satırları bir araya toplayıp en üste almak
yardımcı olabilir misiniz?

 

[emrebenn]

Deneyiniz

Dim i As Integer
Dim LastRow As Integer
Dim ListViewItem As Object
Dim ListViewColumnD As Range
Dim redItems As New Collection

LastRow = Sheets("Puantaj").Cells(Sheets("Puantaj").Rows.Count, "D").End(xlUp).Row

' Kırmızıya boyanmış öğeleri koleksiyona ekleyin
For i = 1 To ListView1.ListItems.Count
Set ListViewItem = ListView1.ListItems(i)
Set ListViewColumnD = Sheets("Puantaj").Range("D7" & LastRow).Find(ListViewItem.ListSubItems(1).Text)
If Not ListViewColumnD Is Nothing Then
ListViewItem.ForeColor = RGB(255, 0, 0) ' Kırmızı renk
redItems.Add ListViewItem.Index
End If
Next i

' Kırmızıya boyanmış öğeleri en üste taşıyın
For i = redItems.Count To 1 Step -1
ListView1.ListItems(redItems(i)).Move 1, lvwItemPos
Next i