• DİKKAT

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

Kişilere ait bilgileri getirme

Sayın Korhan Bey, Sayfa2'deki ana veri aralarına boşluk atmış olsak daha kolay veri aktarır mı?
 

Ekli dosyalar

Bence boşluk eklemeye gerek yok.

Kurguyu düzgün yapmak gerekiyor.

Sanırım bu sefer oldu gibi..

Deneyiniz. Sizde ki veri sayısını 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
                        X = 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 X > 1 Then
                If Veri(X - 1, 5) & Veri(X - 1, 7) & Veri(X - 1, 8) <> Veri(X, 5) & Veri(X, 7) & Veri(X, 8) Then
                    If Sayac < X Then Sayac = X
                End If
            End If
        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
 
Sayın Korhan Bey, ellerinize sağlık çok teşekkür ediyorum.
Küçük bi sorun daha var gibi onu da halledersiniz süper olacak.

Örneğin NEWSHA KAR isimli şahsı Hakkari'ye eklediğim zaman bu şahıs orda tek olduğu için mi bilmiyorum, getirmiyor.
Yani bu şahıstan 4 tane ayrı olarak aktarması gerekiyor.
 
Sorun çıkaran dosyayı paylaşır mısınız?
 
NEWSHA KAR isimli şahsı 2.safyadaki 9.sıradaki Hakkari Esendere Kara Hudut Kapısına ekledim,
bu satırı aktarmadı.
 

Ekli dosyalar

#22 nolu mesajımda ki kodu güncelledim.

Deneyip sonucu bildirirseniz sevinirim.
 
Sayın Korhan Bey, sizi çok uğraştırdım hakkınızı helal edin, şimdi tam istediğim gibi çalışıyor, çok teşekkür ediyorum.

Kodu kendi orijinal dosyamda da denedim, süper oldu, Allah razı olsun.

En fazla kaydı olanı aktarma süresi 0,16 saniye yazıyor ama aktarma 1 saniye bile sürmüyor.

Hayırlı geceler diliyorum.
 
Hakkım varsa helal olsun..

İyi geceler..
 
Sayın Korhan Bey, kusura bakmayın tekrar rahatsız ediyorum.

Bilgileri Sayfa3'e aktardığı zaman, aktardığı sayfada hedef şahsıda mavi renk yapabilir misiniz?

Ekte gönderdiğim örnek gibi yapabilir misiniz?

Koşullu biçimlendirme ile yapıyorum, ancak verileri kopyala yapıştır yaparak başka excel sayfasına aldığım zaman koşullu biçimlendirme karışıyor.



225010
 
Deneyiniz.

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
                        X = 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 X > 1 Then
                If Veri(X - 1, 5) & Veri(X - 1, 7) & Veri(X - 1, 8) <> Veri(X, 5) & Veri(X, 7) & Veri(X, 8) Then
                    If Sayac < X Then Sayac = X
                End If
            End If
        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
            If Veri.Offset(, -3).Value = Adi_Soyadi Then Veri.Offset(, -3).Interior.Color = 15773696
        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
 
Sayın Korhan Bey, çok teşekkür ediyorum, ellerinize sağlık tam istediğim gibi çalışıyor.

Hayırlı günler diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst