Makro ile şartlı veri yazdırma

[pitchoute]

Merhaba personel listesi var elimde 4000 kişilik, a sütununda personel adı b-c.......... stunlarinda ocak 2020 itibari ile ay ay şubat 2025 e kadar prim kazanç tutarları var. Makro ile şubat 2025 den başlayıp geriye doğru 3 ay ard arda odemesi sifir olanları bulup hangi ay ödemeye başladıysa o ayı yazmasını istiyorum. Örnek x bir personel ocak 2020 de ödeme almış şubat mart nisan 2020 ödeme almamış mayis 2020 den itibaren subat2025 e kadar düzenli odemesi var son stuna bana bu mayis 2020 ayını yazması lazım. Şart 3 ay üst üste ödeme almaması yani. Yapabilirmiyiz böyle birsey?

Merhaba, dener misiniz hocam;

Sub UcAyArdisikSifirSonrasiOdeme()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    ws.Cells(1, lastCol + 1).Value = "Ödeme Başlangıç Tarihi"
 
    For i = 2 To lastRow
        Dim found As Boolean
        found = False
        For j = lastCol To 5 Step -1
            If ws.Cells(i, j).Value = 0 And ws.Cells(i, j - 1).Value = 0 And ws.Cells(i, j - 2).Value = 0 Then
                Dim k As Long
                k = j + 1
                If k <= lastCol And ws.Cells(i, k).Value > 0 Then
                    ws.Cells(i, lastCol + 1).Value = ws.Cells(1, k).Value
                    found = True
                    Exit For
                End If
            End If
        Next j
        
        If Not found Then
            ws.Cells(i, lastCol + 1).Value = ""
        End If
    Next i
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

 

[ytemtek07]

Merhaba, dener misiniz hocam;

Sub UcAyArdisikSifirSonrasiOdeme()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    ws.Cells(1, lastCol + 1).Value = "Ödeme Başlangıç Tarihi"

    For i = 2 To lastRow
        Dim found As Boolean
        found = False
        For j = lastCol To 5 Step -1
            If ws.Cells(i, j).Value = 0 And ws.Cells(i, j - 1).Value = 0 And ws.Cells(i, j - 2).Value = 0 Then
                Dim k As Long
                k = j + 1
                If k <= lastCol And ws.Cells(i, k).Value > 0 Then
                    ws.Cells(i, lastCol + 1).Value = ws.Cells(1, k).Value
                    found = True
                    Exit For
                End If
            End If
        Next j
       
        If Not found Then
            ws.Cells(i, lastCol + 1).Value = ""
        End If
    Next i
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

Cok tesekkurler tam istediğim gibi emeğinize sağlık.birsey daha öğrenmek için soruyorum a sütununda personel adı yazıyor "u " stunlarina kadar personel bilgilerini ekledigimde , yani makro kontrolü v stunundan sonrakilere bakacak bu makroda neyi değiştirmelisin?

 

[pitchoute]

Merhaba hocam, rica ederim öncelikle. Şu şekilde makroyu revize edip dener misiniz;

Sub UcAyArdisikSifirSonrasiOdeme()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    ws.Cells(1, lastCol + 1).Value = "Ödeme Başlangıç Tarihi"

    For i = 2 To lastRow
        Dim found As Boolean
        found = False
        For j = lastCol To ws.Range("V1").Column Step -1
            If ws.Cells(i, j).Value = 0 And ws.Cells(i, j - 1).Value = 0 And ws.Cells(i, j - 2).Value = 0 Then
                Dim k As Long
                k = j + 1
                If k <= lastCol And ws.Cells(i, k).Value > 0 Then
                    ws.Cells(i, lastCol + 1).Value = ws.Cells(1, k).Value
                    found = True
                    Exit For
                End If
            End If
        Next j
      
        If Not found Then
            ws.Cells(i, lastCol + 1).Value = ""
        End If
    Next i
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

Yapılan değişikliği de belirtmek istiyorum açık olması için;

For j = lastCol To 5 Step -1

kodunu

For j = lastCol To ws.Range("V1").Column Step -1

olarak değiştirdim.

 

[ytemtek07]

Harika valla çok fena bir iş yükünden kurtardınız beni