Skip to main content

AccessTr.neT


Döngüyle İşlem Yaptırma Makrosu

Döngüyle İşlem Yaptırma Makrosu

Çözüldü #1
Arkadaşlar Merhaba,

Bir çalışmam üzerinde sizlerden desteklerinizi rica ediyorum.

Çalışmam içerisinde yer alan "B" kolonu bu işlevi gerçekleştirecek alandır. Bir araç düşünün ve aynı tarihte birden fazla yerde uğrama yaptığını beyan eden KM bilgileri yer almaktadır. Benim istediğim sizlerden şu kayıtlar eğer aynı ise "Gerçek KM" alanına bakarak en yüksek değerin karşısına en yüksek KM yazacak ("B Kolonuna") eğer gerçek km ("A") maksimum değerden küçükse "0 -(sıfır)" yazsın eğer aynı ise ilk aynı olduğu büyük değere eşit olduğu km yazıp ("B") diğer geride kalanların hepsine "0-(sıfır)" yazmasını rica ediyorum.


Bu içeriğe belki bir ihtimal yüklenmezse diye ayrıca çalışmayı Google Drive üzerinde yükledim ve oradaki linkide sizinle paylaşıyorum.

Şimdiden herkese çok teşekkürler
.rar Çalışma.rar (Dosya Boyutu: 20,89 KB | İndirme Sayısı: 2)
Son Düzenleme: 30/03/2020, 15:44, Düzenleyen: Lenadro.
Cevapla
#2
Birşeyler yaptım lakin tam doğruluğundan emin değilim çünkü istediğiniz karışık durum.
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
.rar Çalışma.rar (Dosya Boyutu: 23,93 KB | İndirme Sayısı: 2)
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task