• DİKKAT

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

sicil tarih ve girişe göre saat çekme

Z

zehfeysal

Katılım
24 Şubat 2010
Mesajlar
281
Excel Vers. ve Dili
EXCEL 2003
sayfa 1 deki tabloya
DATA sayfasındanki personelin (sicil) tarih ve giris saatine göre
sayfa 1 deki tabloda görebiliyorum ancak data yı sap programından guncelleyince farklı siciller eklenince kod calışmıyor kodu güncelleye bilirizmi
Option Explicit

Private Sub btnAktar_Click()
Range("d3:aı1000").ClearContents
Dim Say As Integer
Dim SayTarih As Integer
Dim Tarih As Variant
Dim Sicil As Variant
Dim Bak As Range
Dim BulSatir As Integer
Dim BulSutun As Range
With Worksheets("data")
Say = .Cells(Rows.Count, "C").End(xlUp).Row
SayTarih = Cells(1, Columns.Count).End(xlToLeft).Column
For Each Bak In .Range("A2:A" & Say)
Sicil = Bak.Text
Tarih = .Cells(Bak.Row, "I")
BulSatir = Range("C:C").Find(Sicil).Row
For Each BulSutun In Range("I1:" & Cells(1, SayTarih).Address)
If Tarih = BulSutun And .Cells(Bak.Row, "F").Text = "Giriş" Then
Cells(BulSatir, BulSutun.Column) = .Cells(Bak.Row, "H").Text




Exit For
End If
Next
Next
End With
MsgBox "Aktarma tamamlandı.", vbInformation
End Sub
 

Ekli dosyalar

Sorun tarih formatlarından kaynaklanıyor.

"Data" sayfasındaki tarihlerin formatı "Genel"
"Sayfa1 sayfasındaki tarihlerin formatı "Tarih"

Sorun buradan kaynaklanıyor.

Aşağıdaki kodları kullanabilirsiniz.
Yine de olmazsa her iki sayfadaki tarihlerin formatlarını tarih olarak düzeltin.

Kod: 
Option Explicit

Private Sub btnAktar_Click()
    Range("d3:aı1000").ClearContents
    Dim Say As Integer
    Dim SayTarih As Integer
    Dim Tarih As Variant
    Dim Sicil As Variant
    Dim Bak As Range
    Dim BulSatir As Integer
    Dim BulSutun As Range
    Dim Bul As Range
    With Worksheets("data")
        Say = .Cells(Rows.Count, "C").End(xlUp).Row
        SayTarih = Cells(1, Columns.Count).End(xlToLeft).Column
        For Each Bak In .Range("A2:A" & Say)
            If .Cells(Bak.Row, "F").Text = "Giriş" Then
                Sicil = Bak.Text
                Tarih = .Cells(Bak.Row, "D")
                Set Bul = Range("C:C").Find(Sicil)
                If Not Bul Is Nothing Then
                    BulSatir = Bul.Row
                    For Each BulSutun In Range("E1:" & Cells(1, SayTarih).Address)
                        If Tarih = BulSutun.Text Then
                            Cells(BulSatir, BulSutun.Column) = .Cells(Bak.Row, "H").Text
                            Exit For
                        End If
                    Next
                End If
            End If
        Next
    End With
    MsgBox "Aktarma tamamlandı.", vbInformation
End Sub
 
Sn dalgalikur ' un müsadesi ile , söylediklerine katılmakla beraber bende bir alternatif hazırladım önceki kodlarınızı dikkate almadan,aşağıdaki kodları kullanabilirsiniz .
Kod: 
Option Explicit
Private Sub btnAktar_Click()
    Dim SayTarih As Integer, Bak As Range, BulSatir As Integer, BulSutun As Range
    Range("D3:AI1000").ClearContents
    On Error Resume Next
    With Worksheets("data")
        SayTarih = Cells(1, Columns.Count).End(xlToLeft).Column
        For Each Bak In .Range("A2:A" & .Cells(Rows.Count, "C").End(xlUp).Row)
            BulSatir = Range("C:C").Find(Bak.Value).Row
            If BulSatir <> 0 And .Cells(Bak.Row, "F").Text = "Giriş" Then
                For Each BulSutun In Range("D1:" & Cells(1, SayTarih).Address)
                    If CDate(.Cells(Bak.Row, "D")) = BulSutun And .Cells(Bak.Row, "F").Text = "Giriş" Then
                        Cells(BulSatir, BulSutun.Column) = .Cells(Bak.Row, "H").Text
                        Exit For
                    End If
                Next
            End If
        Next
    End With
    MsgBox "Aktarma tamamlandı.", vbInformation
End Sub
 
Allah razı olsun iki kodda sorunsuz çalışıyor
Dalgalıkur ve EmrExcel16 çok tesekkurler
 
kodlar çalışıyor güzel olmuş Fakat bir sıkıntı daha var aynı tarihte iki defa giriş varsa ilk girişi görmesini istiyorum ikinci girişi getiriyor kodda nasıl bir düzltme yapabiliriz
 

Ekli dosyalar

Bu şekilde deneyiniz..
Kod: 
Option Explicit
Private Sub btnAktar_Click()
    Dim SayTarih As Integer, Bak As Range, BulSatir As Integer, BulSutun As Range
    Range("D3:AI1000").ClearContents
    On Error Resume Next
    With Worksheets("data")
        SayTarih = Cells(1, Columns.Count).End(xlToLeft).Column
        For Each Bak In .Range("A2:A" & .Cells(Rows.Count, "C").End(xlUp).Row)
            BulSatir = Range("C:C").Find(Bak.Value).Row
            If BulSatir <> 0 And .Cells(Bak.Row, "F").Text = "Giriş" Then
                For Each BulSutun In Range("D1:" & Cells(1, SayTarih).Address)
                    If CDate(.Cells(Bak.Row, "D")) = BulSutun And .Cells(Bak.Row, "F").Text = "Giriş" Then
                        If Cells(BulSatir, BulSutun.Column) = "" Then
                            Cells(BulSatir, BulSutun.Column) = .Cells(Bak.Row, "H").Text
                            Exit For
                        Else
                            Exit For
                        End If
                    End If
                Next
            End If
        Next
    End With
    MsgBox "Aktarma tamamlandı.", vbInformation
End Sub
 
kodda bir düzenleme yapılması gerekiyor sanırım giriş bilgisi olmayan tarihe veri atıyor örnek dosyayı attım
 

Ekli dosyalar

Deneyin.
Kod: 
Option Explicit
Private Sub btnAktar_Click()
    Dim SayTarih As Integer, Bak As Range, BulSatir As Integer, BulSutun As Range
    Range("D3:AI1000").ClearContents
    On Error Resume Next
    With Worksheets("data")
        SayTarih = Cells(1, Columns.Count).End(xlToLeft).Column
        For Each Bak In .Range("A2:A" & .Cells(Rows.Count, "C").End(xlUp).Row)
            BulSatir = 0
            BulSatir = Range("C:C").Find(Bak.Value, LookIn:=xlValues, LookAt:=xlWhole).Row
            If BulSatir <> 0 And .Cells(Bak.Row, "F").Text = "Giriş" Then
                For Each BulSutun In Range("D1:" & Cells(1, SayTarih).Address)
                    If CDate(.Cells(Bak.Row, "D")) = BulSutun And .Cells(Bak.Row, "F").Text = "Giriş" Then
                        If Cells(BulSatir, BulSutun.Column) = "" Then
                            Cells(BulSatir, BulSutun.Column) = .Cells(Bak.Row, "H").Text
                            Exit For
                        Else
                            Exit For
                        End If
                    End If
                Next
            End If
        Next
    End With
    MsgBox "Aktarma tamamlandı.", vbInformation
End Sub
 
önçelikle yardımlarınız için tesekkurler kodlar istediğim gibi çalışıyor
geliştirmek adına bir sey daha ekleyebilirmiyiz sayfa 1 de tabloda veri varsa üzerine yazmıyor
Range("D3:AI1000").ClearContents kodunu iptal ediyorum personel hafta tatine T yazıyorum çalıştıysa kart basması varsa T nin olduğu hücreye saat yazmıyor
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst