ZAMAN sütunundakiler sıralıysa sorun olmaz.
Değilse ona göre tekran ayarlanması gerek.Ali cimri hocamızın Ado yöntemide öyle heralde.
Private Sub CommandButton1_Click()
Dim dic As Object
Dim son As Long, i As Long, aranan, aranan2, aranan3
Dim say As Long, arr()
say = 1
With ThisWorkbook.Sheets("Sayfa1")
.Range("H2:K" & Rows.Count).ClearContents
son = .Range("A" & Rows.Count).End(3).Row
ReDim arr(1 To son, 1 To 4)
If son < 2 Then Exit Sub
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To son
aranan = .Cells(i, 1).Value
aranan2 = .Cells(i, 2).Value
aranan3 = .Cells(i, 4).Value
If .Cells(i, 3).Value = "AÇIK" Then
If Not dic.Exists(aranan & "||" & aranan2) Then
dic.Add aranan & "||" & aranan2, aranan3
arr(say, 1) = aranan
arr(say, 2) = aranan2
arr(say, 3) = aranan3
arr(say, 4) = Empty
say = say + 1
End If
End If
Next
'----------------------------------------------------------
Set dic = CreateObject("Scripting.Dictionary")
say = 1
For i = 2 To son
aranan = .Cells(i, 1).Value
aranan2 = .Cells(i, 2).Value
aranan3 = .Cells(i, 4).Value
If .Cells(i, 3).Value = "KAPALI" Then
If Not dic.Exists(aranan & "||" & aranan2) Then
dic.Add aranan & "||" & aranan2, aranan3
arr(say, 4) = aranan3
say = say + 1
End If
End If
Next
If dic.Count > 0 Then .Range("H2").Resize(dic.Count, 4).Value = arr
End With
MsgBox "Bitti"
Set dic = Nothing: Erase arr
aranan = Empty: aranan2 = Empty: aranan3 = Empty
End Sub
