• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

listeleme hk. (ay içinde çalışmış olanlar)

N

nongeyikm

Katılım
7 Kasım 2005
Mesajlar
505
Excel Vers. ve Dili
Office 365 TR-64
Merhaba arkadaşlar,

ekli dosyayı buradaki hocalarımın katkıları ile yaptım.
dosyadaki "Günlük personel listesi" sayfasında "Ay içinde çalışanlar" butonuna makro atamak istiyorum. Butonun altındaki tarih hangi ay ise, o ay içinde çalışmakta olanların listelenmesini istiyorum.

Bu butonun amacı;
Hücreye girilen ay içinde SGK bildirgesi düzenlenecek personellerin tespit edilmesi.

Saygılarımla,
 

Ekli dosyalar

Merhaba,
Bu şekilde deneyin.
Detaylı deneme yapmadım.

Kod: 
Sub veri_al_gun_ici_cikis_haric()
    
    Dim Sp As Worksheet, i As Long, sat As Long

    Set Sp = Sheets("personel giriş-çıkışlar")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("Günlük personel listesi").Select
    Range("A6:E" & Rows.Count).ClearContents

    sat = 6
    For i = 9 To Sp.Cells(Rows.Count, "C").End(xlUp).Row
        If Sp.Cells(i, "E") <= DateSerial(Year([I4]), Month([I4]) + 1, 0) Then
            If Sp.Cells(i, "F") = "" Or _
                Sp.Cells(i, "F") >= CDate("1." & Month([I4]) & "." & Year([I4])) Then
                Sp.Cells(i, "B").Resize(1, 4).Copy Cells(sat, "B")
                sat = sat + 1
            End If
        End If
    Next i

    Range("A6") = 1
    Range("A6:A" & sat - 1).DataSeries Rowcol:=xlColumns, _
        Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
End Sub

.
 
Merhaba Ömer Bey,

Elinize beyninize sağlık. Küçük bir detay dışında gayet güzel çalışıyor. Örneğin 10.ay listesini almak için hücredeki tarih değerini 01.10.2017 yapmak gerekiyor. hücre değeri 26.10.2017 olduğunda ise, 25.10.2017 tarihine kadar işten çıkanları listeye dahil etmiyor.

Saygılarımla,
 
#2 numaralı mesajdaki kodları güncelledim.

.
 
Ömer Bey,

Affınıza sığınarak, aşağıda sizin yaptığınız da dahil 3 modülde de F sütunundaki verileri de çekmesini/listelemesini istiyorum. verileri çekmesinde bir sorun yok. sadece işten çıkış sütununu da çekmesini istiyorum. Hangi tanımları değişeceğimi çözemedim.
:)) Yardımcı olurmusunuz.

---------------------------------------------
'kırmızı bölümlerdeki E leri F yapın
Sub veri_al_gun_sonu()
Set Sp = Sheets("personel giriş-çıkışlar"): Set sg = Sheets("Günlük personel listesi")
sg.Range("A6:E" & sg.Range("A" & Rows.Count).End(3).Row + 1).ClearContents
Application.ScreenUpdating = False
For i = 9 To Sp.Cells(Rows.Count, 2).End(3).Row
son = sg.Range("A" & Rows.Count).End(3).Row + 1
If Sp.Cells(i, "F") = "" And Sp.Cells(i, "E") <= sg.Cells(1, "E") Then
sg.Cells(son, 1) = WorksheetFunction.Max(sg.Range("A6:A" & son)) + 1
Sp.Range("B" & i & ":E" & i).Copy sg.Cells(son, "B")
Else
If Sp.Cells(i, "F") > sg.Cells(1, "E") And Sp.Cells(i, "E") <= sg.Cells(1, "E") Then
sg.Cells(son, 1) = WorksheetFunction.Max(sg.Range("A6:A" & son)) + 1
Sp.Range("B" & i & ":E" & i).Copy sg.Cells(son, "B")
End If
End If
Next i
Application.ScreenUpdating = True
End Sub


---------------------------------------------
'kırmızı bölümlerdeki E leri F yapın
Sub veri_al_gun_ici()
Set Sp = Sheets("personel giriş-çıkışlar"): Set sg = Sheets("Günlük personel listesi")
sg.Range("A6:E" & sg.Range("A" & Rows.Count).End(3).Row + 1).ClearContents
Application.ScreenUpdating = False
For i = 9 To Sp.Cells(Rows.Count, 2).End(3).Row
son = sg.Range("A" & Rows.Count).End(3).Row + 1
If Sp.Cells(i, "F") = "" And Sp.Cells(i, "E") <= sg.Cells(1, "E") Then
sg.Cells(son, 1) = WorksheetFunction.Max(sg.Range("A6:A" & son)) + 1
Sp.Range("B" & i & ":E" & i).Copy sg.Cells(son, "B")
Else
If Sp.Cells(i, "F") >= sg.Cells(1, "E") And Sp.Cells(i, "E") <= sg.Cells(1, "E") Then
sg.Cells(son, 1) = WorksheetFunction.Max(sg.Range("A6:A" & son)) + 1
Sp.Range("B" & i & ":E" & i).Copy sg.Cells(son, "B")
End If
End If
Next i
Application.ScreenUpdating = True
End Sub

------------------------------------------------------------------------
'kırmızı bölümdeki E yi F yapın
'ayrıca kırmızı işaretli 4 yerine de 5 yazın
Sub veri_al_SGK_listesi()

Dim Sp As Worksheet, i As Long, sat As Long

Set Sp = Sheets("personel giriş-çıkışlar")

Application.ScreenUpdating = False
Application.Calculation = xlManual
Sheets("Günlük personel listesi").Select
Range("A6:E" & Rows.Count).ClearContents

sat = 6
For i = 9 To Sp.Cells(Rows.Count, "C").End(xlUp).Row
If Sp.Cells(i, "E") <= DateSerial(Year([E2]), Month([E2]) + 1, 0) Then
If Sp.Cells(i, "F") = "" Or _
Sp.Cells(i, "F") >= CDate("1." & Month([E2]) & "." & Year([E2])) Then
Sp.Cells(i, "B").Resize(1, 4).Copy Cells(sat, "B")
sat = sat + 1
End If
End If
Next i

Range("A6") = 1
Range("A6:A" & sat - 1).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

End Sub
 
Son eklediğiniz mesajda ilgili bölümleri kırmızı ile işaretledim ve üzerine açıklama ekledim.
Bu doğrultuda değişiklikleri yaparak deneyin.

.
 
Günaydın Ömer Bey,

Söylediğiniz şekilde yaptım ve oldu. Sayfayı koruma yaptığımda sizin kod ekteki hatayı veriyor.

Saygılar,
 

Ekli dosyalar

  • Yeni Bit Eşlem Resmi.jpg
    Yeni Bit Eşlem Resmi.jpg
    288 KB · Görüntüleme: 5
Son düzenleme:
Bu şekilde deneyin.

Kod: 
Sub veri_al_SGK_listesi()
    
    Dim Sp As Worksheet, i As Long, sat As Long

    Set Sp = Sheets("personel giriş-çıkışlar")

    Application.ScreenUpdating = False
    ActiveSheet.Unprotect
    Application.Calculation = xlManual
    Sheets("Günlük personel listesi").Select
    Range("A6:F" & Rows.Count).ClearContents

    sat = 6
    For i = 9 To Sp.Cells(Rows.Count, "C").End(xlUp).Row
        If Sp.Cells(i, "E") <= DateSerial(Year([E2]), Month([E2]) + 1, 0) Then
            If Sp.Cells(i, "F") = "" Or _
                Sp.Cells(i, "F") >= CDate("1." & Month([E2]) & "." & Year([E2])) Then
                Sp.Cells(i, "B").Resize(1, 5).Copy Cells(sat, "B")
                Cells(sat, "A") = sat - 5
                sat = sat + 1
            End If
        End If
    Next i
    
    Application.Calculation = xlAutomatic
    ActiveSheet.Protect
    Application.ScreenUpdating = True
    
End Sub

.
 
Ömer Bey,
Sorunu hallettiniz. Çok çok teşekkür eder, saygılar sunarım.
 
Ömer Bey merhaba,

Ekli çalışmayı sizlerin desteği ve yardımları ile yaptım. Zaten hemen hemen tamamı sizlere ait.

Ekli dosyada "Günlük personel listesi" sayfasında; "ay içi çalışanlar bordro bildirge" butonuna basıldığında buradaki makro A6:F.... aralığında personelleri listeliyor.

bu butona basıldığında, R1:AN1 aralığındaki förmülleri listelenen her kişi kadar aşağıya doğru kopyalayabilirmiyiz. (bunu manuel kopyalıyorum).

Ayrıca yine bu butona bastığımda çıkış tarihi olsun veya olmasın R3 hücresinde belirtilen ayda çalışanlar listeleniyor. Fakat R3 hücresinde belirtilen aydan sonraki ayda çıkış yapan personellerin çıkış tarihini yazdırmamak gerekiyor? (çıkış tarihi boş kalmalı)

Saygılarımla,
 

Ekli dosyalar

İstediğiniz bu mu?

Kod: 
Sub veri_al_SGK_listesi()
    
    Dim Sp As Worksheet, i As Long, sat As Long

    Set Sp = Sheets("personel giriş-çıkışlar")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("Günlük personel listesi").Select
    Range("A6:AN" & Rows.Count).ClearContents

    sat = 6
    For i = 9 To Sp.Cells(Rows.Count, "C").End(xlUp).Row
        If Sp.Cells(i, "E") <= DateSerial(Year([R3]), Month([R3]) + 1, 0) Then
            If Sp.Cells(i, "F") = "" Or _
                Sp.Cells(i, "F") >= CDate("1." & Month([R3]) & "." & Year([R3])) Then
                Sp.Cells(i, "B").Resize(1, 5).Copy Cells(sat, "B")
                Cells(sat, "A") = sat - 5
                If Sp.Cells(i, "F") > [S4] Then Cells(sat, "F").ClearContents
                sat = sat + 1
            End If
        End If
    Next i
    
    Range("R1:AN1").Copy Range("R6:AN" & sat - 1)
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
End Sub

.
 
Ömer Bey,

Bendeki akıl/zeka ise sizde olanı çok merak ediyorum. :))))) Harikasınız.

Allah razı olsun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst