Adı soyadını yazınca yanına telefon numarası getirme

[dedenet]

Eklediğim dosyada bir ana liste ve bir de telefon listesi var.
Kişinin ismini yazınca telefon listesinden düşeyara ile telefon numarasını çekiyorum.
Ancak liste çok geniş olduğu için formüller yer kaplıyor ve kasıyor.

Bunun için şunu istiyorum:
Listedeki herhangi bir isim alanına adı soyadını yazınca makro hemen çalışsın
ve diğer telefon listesi dosyasından numarayı çeksin ve formülü değerlere dönüştürsün.

 

[Necdet]

Merhaba,

İki dosyayı tek dosyada neden birleştirmiyorsunuz?
İşlemler daha kısa olur.

 

[dedenet]

Ana liste çok geniş ve teferruatlı. sorumu anlatmak için ben sadece çok küçük bir kısmını ekledim.
2 dosya birbirinden ayrı. birleştirme imkanım yok

 

[dedenet]

İki dosya ayrı veya aynı çalışma kitabı içinde olsun, benim isteğim
B sütununa adı soyadı yazınca, makronun çalışması (yanındaki hücreye telefon numarasını çekecek formülü yazıp, formülün değerlere dönüşmesi)

 

[Orion1]

Buyurun.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim conn As Object, rs As Object
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Offset(0, -1).Value = "NO" Then Exit Sub
Target.Offset(0, 1).Value = ""
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
        "\Telefonlar.xlsx;extended properties=""excel 12.0;hdr=no""")

rs.Open ("select * from[İsim ve Telefon$B2:C65536] where F1='" & Target.Value & "';"), conn, 1, 1
If rs.RecordCount > 0 Then Target.Offset(0, 1).Value = rs(1).Value
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
End Sub

 

[Korhan Ayhan]

Alternatif;

LİSTE isimli sayfanızın kod bölümüne uygulayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Yol As String
        
    If Intersect(Target, Range("B5:B" & Rows.Count)) Is Nothing Then Exit Sub
    If Target.Interior.ColorIndex <> 2 And Target.Interior.ColorIndex <> xlNone Then Exit Sub
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
        
    With Target.Offset(0, 1)
        .Formula = "=INDEX('" & Yol & "[Telefonlar.xlsx]İsim ve Telefon'!$B:$C,MATCH(""" & Target.Value & _
                   """," & "'" & Yol & "[Telefonlar.xlsx]İsim ve Telefon'!$B:$B,0),2)"
        .Value = .Value
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[Utekiner]

@Korhan Ayhan Bey

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Anlamını merak ettim bir çok kodda bu kullanıyor. Ne gibi bir özelliği var acaba.

 

[netzone]

Merhaba @Utekiner,

Ekran güncellemesi Application.ScreenUpdating = True/False ve otomatik hesaplamanın Application.Calculation = xlCalculationAutomatic/xlCalculationManual kapatılmasını ifade ediyor. Bu kodları içeren makronun öncelikli olarak işlemi gerçekleştirmesi için, makro başlatıldığında kapatılır ve makronun bitiminde dosyanızın işlevini değiştirmemek için tekrar aktif edilir.

İyi çalışmalar.

 

[Utekiner]

teşekkür eder,m. Bilgilendirme icin

 

[dedenet]

Sayın Korhan Ayhan'a ve Sayın Orion1'e çok teşekkür ederim.
Ancak kodlarınızı kendi dosyama uyguladığımda ekteki ekran görüntüsündeki hata ile karşılaşıyorum.

 

[Korhan Ayhan]

Aynı isimle başlayan bir kod bloğu olabilir.

Worksheet Change bloğunu tek olarak deneyin.

 

[dedenet]

Aynı isimle başlayan bir kod bloğu olabilir.

Worksheet Change bloğunu tek olarak deneyin.

aynı sayfa içinde
Private Sub Worksheet_Change(ByVal Target As Range)
ile başlayan başka bir kod daha var.

her iki kod da bana lazım. ne yapmalıyım?

 

[Korhan Ayhan]

İkisini uygun şekilde birleştirmeniz gerekiyor.

 

[dedenet]

İkisini uygun şekilde birleştirmeniz gerekiyor.

Korhan Bey, aşağıdaki iki kodu nasıl birleştirebilirim.


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E1]) Is Nothing Then Exit Sub
For i = 2 To 50
If Target.Value = Cells(i, 2).Value Then
Cells(i, 2).Select
End If
ActiveWindow.ScrollRow = [$E$1] * 11 - 9
Next
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Yol As String

If Intersect(Target, Range("B5:B" & Rows.Count)) Is Nothing Then Exit Sub
If Target.Interior.ColorIndex <> 2 And Target.Interior.ColorIndex <> xlNone Then Exit Sub

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Yol = ThisWorkbook.Path & Application.PathSeparator

With Target.Offset(0, 1)
.Formula = "=INDEX('" & Yol & "[Telefon Arşivi.xlsx]İSİM-TLF'!$B:$C,MATCH(""" & Target.Value & _
"""," & "'" & Yol & "[Telefon Arşivi.xlsx]İSİM-TLF'!$B:$B,0),2)"
.Value = .Value
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[YUSUF44]

Şöyle dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E1]) Is Nothing Then GoTo 10
For i = 2 To 50
If Target.Value = Cells(i, 2).Value Then
Cells(i, 2).Select
End If
ActiveWindow.ScrollRow = [$E$1] * 11 - 9
Next

10:
Dim Yol As String

If Intersect(Target, Range("B5:B" & Rows.Count)) Is Nothing Then Exit Sub
If Target.Interior.ColorIndex <> 2 And Target.Interior.ColorIndex <> xlNone Then Exit Sub

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Yol = ThisWorkbook.Path & Application.PathSeparator

With Target.Offset(0, 1)
.Formula = "=INDEX('" & Yol & "[Telefon Arşivi.xlsx]İSİM-TLF'!$B:$C,MATCH(""" & Target.Value & _
"""," & "'" & Yol & "[Telefon Arşivi.xlsx]İSİM-TLF'!$B:$B,0),2)"
.Value = .Value
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[dedenet]

Sayın YUSUF44 kod alışıyor, çok teşekkür ederim.
Ancak iki kod arasına yazdığınız 10: ne işe yarıyor, 10 diye öylesine mi yazdınız, yoksa 10 olmasının özel bir sebebi var mı?
15, 26, 138... yazsaydınız da aynı işi görür müydü?

 

[YUSUF44]

Özel bir anlamı yok. Belirttiğiniz sayılar da olurdu ya da daha önce denemedim ama muhtemelen herhangi bir kelime de olurdu.

Dikkat ederseniz en üstte GoTo 10 ifadesi var. O ifade eğer ilk şart sağlanmıyorsa 10 ile belirttiğim yere atla anlamına geliyor. Yukarda GoTo 238 deyip aşağıda da 238: yazabilirdim.