Kişilere ait bilgileri getirme

ASLAN7410 · 31 Ocak 2021

Merhaba hayırlı günler.

Ekte gönderdiğim excel dosyamın 1.sayfasında isimler bulunuyor, 2.sayfasında da bu şahısların ülkeye giriş ve çıkış tarihleri mevcut.

Yapmak istediğim 1.sayfadaki isimlerdeki I2 hücresinden seçtiğim ismi GETİR butonuna bastığımda bu şahsı 2.sayfadan bulup, o tarihteki giriş veya çıkışına göre aynı tarih aralığındakileri 3.sayfaya getirmek istiyorum.

Satır sayım çok fazla olduğu için elle kontrol çok zor oluyor.

Yardımcı olur musunuz?

zehfeysal · 31 Ocak 2021

deneyin isteginize göre düzenliyebiliriz

ASLAN7410 · 31 Ocak 2021

Sayın zehfeysal ilginize çok teşekkür ediyorum, benim istediğim sonucu vermiyor.

Yapmak istediğim Sayfa3'teki gibi istemiştim.

Korhan Ayhan · 1 Şubat 2021

Sayfa2'de F sütununda "xxx" yazan yerlerde isimler var değil mi?

ASLAN7410 · 1 Şubat 2021

Evet Korhan Bey.
Yani yapmak istediğim ismi yazılı şahıs kimlerle birlikte ona bakmak istiyorum.

Korhan Ayhan · 1 Şubat 2021

Sorumu şu şekilde sorayım;

F3:F7 arasında hangi isim yazıyor?

ASLAN7410 · 1 Şubat 2021

Sayın Korhan Bey, F sütunundaki xxx yazan yerlerde başka kişi isimleri mevcut.
Dediğiniz yere farklı farklı isimler yazılabilir.

Yapmak istediğim Sayfa1'de I2 hücresindeki seçmiş olduğum şahıs Sayfa2'de varsa aynı tarihteki giriş yazana göre Sayfa 3'e kopyalamak istemiştim.

Yani hedef şahıs kimlerle birlikte olmuş, onları ayırmak istiyorum.

Korhan Ayhan · 1 Şubat 2021

Bir sorum daha olacak;

Sayfa2'de H8:H12 arası GİRİŞ olsaydı bizim için bu iki bloğu (ALİ VELİ / VELİ ALİ) ayrıştıran bölüm neresi olacaktı?

Korhan Ayhan · 1 Şubat 2021

Deneyiniz.

Sizde ki veride işlem süresini ve veri sayısını bildirirseniz sevinirim.

C++:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Veri As Variant, Son As Long, X As Long, Adi_Soyadi As String
    Dim Y As Integer, Say_Giris As Long, Say_Cikis As Long, Zaman As Double
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
        .EnableEvents = 0
    End With
           
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
   
    S3.Range("A2:H" & S3.Rows.Count).Clear
   
    Adi_Soyadi = S1.Range("I2").Value
   
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
   
    Veri = S2.Range("A2:H" & Son).Value
   
    ReDim Liste_Giris(1 To Son, 1 To 8)
    ReDim Liste_Cikis(1 To Son, 1 To 8)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 6) = Adi_Soyadi Then
            If Veri(X, 8) = "GİRİŞ" Then
                For Y = X To 1000
                    If Y > UBound(Veri, 1) Then Exit For
                    If Veri(X, 7) = Veri(Y, 7) And Veri(X, 8) = Veri(Y, 8) Then
                        Say_Giris = Say_Giris + 1
                        Liste_Giris(Say_Giris, 1) = Say_Giris
                        Liste_Giris(Say_Giris, 2) = Veri(X, 2)
                        Liste_Giris(Say_Giris, 3) = Veri(X, 3)
                        Liste_Giris(Say_Giris, 4) = Veri(X, 4)
                        Liste_Giris(Say_Giris, 5) = Veri(X, 5)
                        Liste_Giris(Say_Giris, 6) = Veri(X, 6)
                        Liste_Giris(Say_Giris, 7) = Veri(X, 7)
                        Liste_Giris(Say_Giris, 8) = Veri(X, 8)
                    Else
                        X = Y - 1
                        GoTo 10
                    End If
                Next
               
            ElseIf Veri(X, 8) = "ÇIKIŞ" Then
                For Y = X To 1000
                    If Y > UBound(Veri, 1) Then Exit For
                    If Veri(X, 7) = Veri(Y, 7) And Veri(X, 8) = Veri(Y, 8) Then
                        Say_Cikis = Say_Cikis + 1
                        Liste_Cikis(Say_Cikis, 1) = Say_Cikis
                        Liste_Cikis(Say_Cikis, 2) = Veri(X, 2)
                        Liste_Cikis(Say_Cikis, 3) = Veri(X, 3)
                        Liste_Cikis(Say_Cikis, 4) = Veri(X, 4)
                        Liste_Cikis(Say_Cikis, 5) = Veri(X, 5)
                        Liste_Cikis(Say_Cikis, 6) = Veri(X, 6)
                        Liste_Cikis(Say_Cikis, 7) = Veri(X, 7)
                        Liste_Cikis(Say_Cikis, 8) = Veri(X, 8)
                    Else
                        X = Y - 1
                        GoTo 10
                    End If
                Next
            End If
        End If
10  Next
   
    S3.Select
   
    If Say_Giris > 0 Then
        S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).Resize(Say_Giris, 8).Borders.LineStyle = 1
        S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).Resize(Say_Giris, 8) = Liste_Giris
    End If
   
    If Say_Cikis > 0 Then
        If Say_Giris > 0 Then
            S3.Cells(S3.Rows.Count, 1).End(3)(3, 1).Resize(Say_Cikis, 8).Borders.LineStyle = 1
            S3.Cells(S3.Rows.Count, 1).End(3)(3, 1).Resize(Say_Cikis, 8) = Liste_Cikis
        Else
            S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).Resize(Say_Cikis, 8).Borders.LineStyle = 1
            S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).Resize(Say_Cikis, 8) = Liste_Cikis
        End If
    End If
   
    If Say_Giris > 0 Or Say_Cikis > 0 Then
        S3.Columns.AutoFit
        S3.Range("A2").Resize(S3.Cells(S3.Rows.Count, 1).End(3).Row).HorizontalAlignment = xlCenter
        S3.Range("G2").Resize(S3.Cells(S3.Rows.Count, 1).End(3).Row).HorizontalAlignment = xlCenter
       
        With Application
            .ScreenUpdating = 1
            .Calculation = -4105
            .EnableEvents = 1
        End With
   
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        With Application
            .ScreenUpdating = 1
            .Calculation = -4105
            .EnableEvents = 1
        End With
   
        MsgBox "Uygun veri bulunamadı!", vbCritical
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
End Sub

ASLAN7410 · 1 Şubat 2021

Sayın Korhan Bey, yazmış olduğunuz kodları orijinal dosyamdaki isimlere benzer şekilde hazırlayarak dosyayı tekrar yüklüyorum.

ASLAN7410 · 1 Şubat 2021

Sayın Korhan Bey,
Yapmak istediğim bu şekilde olması gerekiyor.

Korhan Ayhan · 1 Şubat 2021

Kod içindeki GİRİŞ ve ÇIKIŞ yazılarını sayfanızda ki gibi Giriş ve Çıkış olarak düzenlerseniz kod çalışacaktır.

Bu şekilde düzenleyip deneyin olmayan yeri varsa düzenleriz.

ASLAN7410 · 1 Şubat 2021

Sayın Korhan Bey, dediğiniz gibi yaptım kodlar gayet güzel çalışıyor ancak istediğim verileri tam olarak getirmiyor.

Bu şahsı getir dediğimde sadece 9 kayıt getiriyor. Getirdiği bilgilerde adı soyadı kısmında da hepsinde şahsın kendi adı yazıyor.

NEWSHA KAR bu şahsın bilgilerin getir dediğimde aşağıdaki resimdeki gibi getirmesini istemiştim.

ASLAN7410 · 1 Şubat 2021

Sayın Korhan Bey, olmayacak galiba pes ediyorum.

Yine de ilgilendiğiniz için çok teşekkür ediyorum.

Hayırlı geceler diliyorum.

Korhan Ayhan · 1 Şubat 2021

Pes etme sebebinizi merak ettim açıkçası..

ASLAN7410 · 2 Şubat 2021

Sayın Korhan Bey, herhangi bir özel sebebi yok, ama sizleri çok yormuş ve uğraştırıyorum diye vaz geçmiştim.

Sorun yok diyorsanız, devam ederseniz sevinirim.

Korhan Ayhan · 2 Şubat 2021

Neden yorulalım...

Forumda 5-6 sayfa boyunca yazıştığımız ve çoğunu çözüme ulaştırdığımız başlıklar var.

Bizleri sıkan şey konunun sonradan değişmesi. Çünkü konsantre olup çözüm üretiyorsunuz. Sonrasında yok benim kendi dosyamda satır şöyleydi, sütun şöyleydi gibi söylemlerde bulunarak yeniden çözüm üretilmesi talep ediliyor.

Korhan Ayhan · 2 Şubat 2021

Deneyiniz.

Fazla dediğiniz veri sayınızı ve işlem süresini bildirirseniz sevinirim.

C++:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Renk As Byte, Aranan As String
    Dim Veri As Variant, Son As Long, X As Long, Adi_Soyadi As String, No As Long
    Dim Y As Long, Sayac As Long, Say As Long, Kontrol As Boolean, Zaman As Double
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
        .EnableEvents = 0
    End With
           
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
   
    S3.Range("A2:H" & S3.Rows.Count).Clear
   
    Adi_Soyadi = S1.Range("I2").Value
   
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
   
    Veri = S2.Range("A2:H" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 9)
   
    Renk = 1
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 6) = Adi_Soyadi Then
            Aranan = Veri(X, 5) & Veri(X, 7) & Veri(X, 8)
            If Sayac = 0 Then Sayac = LBound(Veri, 1)
            For Y = Sayac To UBound(Veri, 1)
                If Aranan = Veri(Y, 5) & Veri(Y, 7) & Veri(Y, 8) Then
                    Say = Say + 1
                    No = No + 1
                    Liste(Say, 1) = No
                    Liste(Say, 2) = Veri(Y, 2)
                    Liste(Say, 3) = Veri(Y, 3)
                    Liste(Say, 4) = Veri(Y, 4)
                    Liste(Say, 5) = Veri(Y, 5)
                    Liste(Say, 6) = Veri(Y, 6)
                    Liste(Say, 7) = Veri(Y, 7)
                    Liste(Say, 8) = Veri(Y, 8)
                    Liste(Say, 9) = Renk
                    Kontrol = True
                Else
                    If Kontrol = True Then
                        Kontrol = False
                        If Renk = 1 Then
                            Renk = 0
                        Else
                            Renk = 1
                        End If
                        No = 0
                        Sayac = Y + 1
                        Say = Say + 1
                        Liste(Say, 1) = ""
                        Liste(Say, 2) = ""
                        Liste(Say, 3) = ""
                        Liste(Say, 4) = ""
                        Liste(Say, 5) = ""
                        Liste(Say, 6) = ""
                        Liste(Say, 7) = ""
                        Liste(Say, 8) = ""
                        Exit For
                    End If
                End If
            Next
        Else
            If Sayac < X Then Sayac = X
        End If
    Next
   
    S3.Select
   
    If Say > 0 Then
        S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).Resize(Say, 9) = Liste
        S3.Range("A2:H" & S3.Rows.Count).SpecialCells(xlCellTypeConstants, 23).Borders.LineStyle = 1
        For Each Veri In S3.Range("I2:I" & S3.Rows.Count).SpecialCells(xlCellTypeConstants, 23)
            If Veri.Value = 0 Then
                Veri.Offset(, -8).Resize(, 8).Interior.Color = 65535
            ElseIf Veri.Value = 1 Then
                Veri.Offset(, -8).Resize(, 8).Interior.Color = 49407
            End If
        Next
        S3.Range("I:I").Clear
        S3.Columns.AutoFit
        S3.Range("A2").Resize(S3.Cells(S3.Rows.Count, 1).End(3).Row).HorizontalAlignment = xlCenter
        S3.Range("G2").Resize(S3.Cells(S3.Rows.Count, 1).End(3).Row).HorizontalAlignment = xlCenter
       
        With Application
            .ScreenUpdating = 1
            .Calculation = -4105
            .EnableEvents = 1
        End With
   
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        With Application
            .ScreenUpdating = 1
            .Calculation = -4105
            .EnableEvents = 1
        End With
   
        MsgBox "Uygun veri bulunamadı!", vbCritical
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
End Sub

ASLAN7410 · 2 Şubat 2021

Sayın Korhan Bey, ilginiz için gerçekten çok teşekkür ediyorum, sizlerde çok haklısınız.

1.kişi BEHZAD SAH aktarmada sorun yok.

2.kişi DAVOUD HAG aktardığında 1 kişi eksik aktarıyor.

Gelen veri.

Olması gereken veri.

3. kişi KIANNA SOLTA aktardığı sayfada boşluktan sonra 1 kişi eksik aktarıyor.

Gelen veri.

Olması gereken veri.

4.kişi NEDA SAMS sorun yok.

5.kişi NEWSHA KAR, aktardığı sayfada ilk bilgi eksik, 1.boşluktan sonra bilgi eksik, 2.boşluktan sonra sorun yok.
Gelen veri.

ASLAN7410 · 2 Şubat 2021

5.kişi NEWSHA KAR,

Olması gereken

Kişilere ait bilgileri getirme

Altın Üye

Ekli dosyalar

Ekli dosyalar

Altın Üye

Administrator

Altın Üye

Administrator

Altın Üye

Administrator

Administrator

Altın Üye

Ekli dosyalar

Altın Üye

Ekli dosyalar

Administrator

Altın Üye

Altın Üye

Administrator

Altın Üye

Administrator

Administrator

Altın Üye

Altın Üye