K sütununa plakalar girilecek.Bence bu şekildr başka sayfaya kodla aktarılıp orda tek tek plaka olarak bulunabilir.
Sub Tayfun()
Dim con As Object, rs As Object
Dim sonK As Integer, ilk As Integer, k As Integer
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no"""
Application.ScreenUpdating = False
With Sheets("Sayfa1")
.Range("B2:B7").ClearContents
sonK = .Cells(Rows.Count, "K").End(3).Row
If sonK < 2 Then GoTo son
For k = 2 To sonK
For i = 2 To 7
Set rs = con.Execute("SELECT max(f6) FROM [Sayfa1$A2:F7] where Right(f5, 8)= '" & .Cells(k, "K").Value & "'")
If Val(.Cells(i, 1).Value) >= Val(rs(0)) Then
ilk = i
.Cells(i, 2).Value = .Cells(i, 6).Value
Set rs = Nothing
Exit For
End If
Next
For i = 2 To 7
If .Cells(k, "K").Value = .Cells(i, 3).Value And i <> ilk Then .Cells(i, 2).Value = 0
Next
Next
son:
con.Close
Set con = Nothing
End With
Application.ScreenUpdating = True
MsgBox "Bitti...", vbInformation, "Bilgi"
End Sub
