• DİKKAT

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

Soru Veri Çekme Hk.

Merhaba Arkadaşım,
Dosyanızdaki veriler umarım geçerli TC lerle oluşturulmuş veriler değildir. Öyle ise lütfen dosyanızı değiştirin.
Dosyanızda istediğiniz işlem için yapmanız gereken; BİRLEŞTİRME sayfanızda gerçek verileri kullanarak işlem yapın, sonrasında A sütunundaki verilerinizi şu andaki haliyle maskeleyin.
iyi çalışmalar
 
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky
    Dim i As Integer

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(dizi(i, 2), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), dizi(i, 2))
    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
 
Tevfik_Kursun' Alıntı:
Merhaba Arkadaşım,
Dosyanızdaki veriler umarım geçerli TC lerle oluşturulmuş veriler değildir. Öyle ise lütfen dosyanızı değiştirin.
Dosyanızda istediğiniz işlem için yapmanız gereken; BİRLEŞTİRME sayfanızda gerçek verileri kullanarak işlem yapın, sonrasında A sütunundaki verilerinizi şu andaki haliyle maskeleyin.
iyi çalışmalar
Genişletmek için tıkla ...
veriler ve tcler gerçek dışıdır
 
veyselemre' Alıntı:
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky
    Dim i As Integer

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(dizi(i, 2), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), dizi(i, 2))
    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
Genişletmek için tıkla ...
Veysel bey cevap için teşekkürler ancak verileri eksik getirdi
 
Hatalı Veri

SERTAÇ BAŞAR

BETÜL KAYA TEKİN

AZİZ KOPUZ
Sertaç Başar ve Aziz Kopuz dan sonra birer boşluk karakteri var.

BE*** KA******** yerine


BE*** TE*** olması lazım verinin gelmesi için. Önceki örneklerde bu şekilde

 
veyselemre' Alıntı:
Hatalı Veri

SERTAÇ BAŞAR

BETÜL KAYA TEKİN

AZİZ KOPUZ
Sertaç Başar ve Aziz Kopuz dan sonra birer boşluk karakteri var.


BE*** KA******** yerine


BE*** TE*** olması lazım verinin gelmesi için. Önceki örneklerde bu şekilde


Genişletmek için tıkla ...

BE*** KA******** yerine


BE*** TE*** olması lazım verinin gelmesi için. Önceki örneklerde bu şekilde
Veysel hocam açıklama için çok teşekkürler bu liste bize sistem üzerinden geldiği için sanırsam bayan personellerde iki soy isim kullandığı zaman listede ilk soy isminin ilk iki harfi olacak şekilde listeleniyor. bay personellerde örneğin İSMAİL MUSTAFA ÖZDEMİR de İS ile ÖZ'ü baz alıyor. Sorun bayan personellerde hem kendi soy ismini hemde eşinin soy ismini kullananlarda sorun yaşıyoruz sanırım. Buna bir çözüm bulabilirmiyiz acaba
 
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky
    Dim i As Integer

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(Trim(dizi(i, 2)), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        If UBound(bl) = 2 Then
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(1), 2)
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        End If

    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky
    Dim i As Integer

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(Trim(dizi(i, 2)), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        If UBound(bl) = 2 Then
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(1), 2)
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        End If

    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
Genişletmek için tıkla ...
Teşekkürler veysel hocam emeğine sağlık istediğim gibi sonuç aldım
 
veyselemre' Alıntı:
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky
    Dim i As Integer

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(Trim(dizi(i, 2)), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        If UBound(bl) = 2 Then
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(1), 2)
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        End If

    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
Genişletmek için tıkla ...

40*******80

FA*** TÜ*** AK*** YI****


63*******52

AB******** GE***** YI****



NA**** YA***** ÖZ** ER***





Veysel hocam merhabalar. Yazmış olduğunuz makroya bu kriterleride bulacak şekilde revize edebilirmisiniz. Bu verilerin karşılığını çekemedim maalesef
 
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky, b, bl, i, ii

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(Trim(dizi(i, 2)), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        If UBound(bl) > 1 Then
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(1), 2)
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2)
            For Each b In bl
                ky = ky & Left(b, 2)
            Next b
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        End If

    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            Else
                ky = Replace(WorksheetFunction.Trim(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", " ")), " ", "*") & "*"
                For ii = 1 To UBound(dizi)
                    If dizi(ii, 1) & dizi(ii, 2) Like ky Then
                        .Cells(i, 3).Value = dizi(ii, 1)
                        .Cells(i, 4).Value = dizi(ii, 2)
                        Exit For
                    End If
                Next ii
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub getir()
    Dim dizi As Variant, dic As Object, ky, b, bl, i, ii

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("GENEL LİSTE")
        dizi = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With

    For i = 1 To UBound(dizi)
        bl = Split(Trim(dizi(i, 2)), " ")
        ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(UBound(bl)), 2)
        dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        If UBound(bl) > 1 Then
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2) & Left(bl(0), 2) & Left(bl(1), 2)
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
            ky = Left(dizi(i, 1), 2) & Right(dizi(i, 1), 2)
            For Each b In bl
                ky = ky & Left(b, 2)
            Next b
            dic(ky) = Array(dizi(i, 1), Trim(dizi(i, 2)))
        End If

    Next i

    With Sheets("BİRLEŞTİRME")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = Replace(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", ""), " ", "")
            If dic.exists(ky) Then
                .Cells(i, 3).Resize(, 2).Value = dic(ky)
            Else
                ky = Replace(WorksheetFunction.Trim(Replace(.Cells(i, 1).Value & .Cells(i, 2).Value, "*", " ")), " ", "*") & "*"
                For ii = 1 To UBound(dizi)
                    If dizi(ii, 1) & dizi(ii, 2) Like ky Then
                        .Cells(i, 3).Value = dizi(ii, 1)
                        .Cells(i, 4).Value = dizi(ii, 2)
                        Exit For
                    End If
                Next ii
            End If
        Next i
    End With

    MsgBox "İŞLEM TAMAM"
End Sub
Genişletmek için tıkla ...
Teşekkürler veysel hocam emeğine sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst