• DİKKAT

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

Soru Makro İle Çaprazara Fonksi̇yonu Kullanma

F

fledermaus

Katılım
18 Kasım 2012
Mesajlar
423
Excel Vers. ve Dili
Microsoft Office 365
Merhaba,

Ekteki dosyayı makro olarak nasıl yazabilirim ?

Liste sayfasında G sütununa TC kimlik no yazıldığında veri sayfasından bilgilerin otomatik olarak hücrelere çekilmesini istiyorum.

Şimdiden çok teşekkür ederim.


Syg,
 

Ekli dosyalar

Aşağıdaki kodları Liste sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) kopyalayıp deneyin. Liste sayfasının G sütununda değişiklik yaptıkça kodlar çalışır:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
Set s1 = Sheets("Veri")
son = s1.Cells(Rows.Count, "G").End(3).Row
If Target = "" Then
    Application.EnableEvents = False
        Range("A" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("G1:G" & son), Target) > 0 Then
    Application.EnableEvents = False
        sat = WorksheetFunction.Match(Target, s1.Range("G1:G" & son), 0)
        s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Target.Select
    Application.EnableEvents = True
Else
    Range("A" & a & ":F" & a) = "Bulunamadı"
    Range("H" & a & ":L" & a) = "Bulunamadı"
End If
End Sub
 
YUSUF44' Alıntı:
Aşağıdaki kodları Liste sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) kopyalayıp deneyin. Liste sayfasının G sütununda değişiklik yaptıkça kodlar çalışır:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
Set s1 = Sheets("Veri")
son = s1.Cells(Rows.Count, "G").End(3).Row
If Target = "" Then
    Application.EnableEvents = False
        Range("A" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("G1:G" & son), Target) > 0 Then
    Application.EnableEvents = False
        sat = WorksheetFunction.Match(Target, s1.Range("G1:G" & son), 0)
        s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Target.Select
    Application.EnableEvents = True
Else
    Range("A" & a & ":F" & a) = "Bulunamadı"
    Range("H" & a & ":L" & a) = "Bulunamadı"
End If
End Sub
Genişletmek için tıkla ...

Hocam Merhaba,

Sanırım makroları hücrelerde geçen xlookup formüllerine göre oluşturdunuz.

Bu makroyu kullanmak zorunda olmamın amacı yükleme yapmış olduğum sitenin hücrelerde geçen formülleri kabul etmeyip yükleme işleminde hata vermesidir.

Ben silmeyi unutmuşum kusura bakmayın. Şimdi silmeye çalıştım ancak bu sefer makrolar çalışmıyorlar.

Hücrelerde formül olmadan makroyu nasıl revize etmemiz gerekir ? Birde hücrelerde veriyi bulamadığında "bulunamadı" uyarı vermesin hücre boş kalsın.

Yardımlarınız için çok teşekkür ederim.

Syg,
 
Sayfa olaylarını aktifleştirmek için aşağıdaki makroyu çalıştırın:

PHP: 
Sub aktif()
    Application.EnableEvents = True
End Sub

Bulunamadı yazmaması için o iki satırdaki = "Bulunamadı" ifadeleri yerine .ClearContents ifadelerini kullanın.
 
Merhaba , alternatif olarak

"Çaprazara" fonksiyonu kullanılmıştır.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("G:G")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    Range("A" & Target.Row & ":F" & Target.Row & ",H" & Target.Row & ":L" & Target.Row) = _
    "=IF(XLOOKUP(RC7,Veri!R2C7:R10000C7,XLOOKUP(R1C,Veri!R1C1:R1C12,Veri!R2C1:R10000C12,""""),"""")=0,"""",XLOOKUP(RC7,Veri!R2C7:R10000C7,XLOOKUP(R1C,Veri!R1C1:R1C12,Veri!R2C1:R10000C12,""""),""""))"
    Range("A" & Target.Row & ":L" & Target.Row).Value = Range("A" & Target.Row & ":L" & Target.Row).Value
End Sub
 
YUSUF44' Alıntı:
Sayfa olaylarını aktifleştirmek için aşağıdaki makroyu çalıştırın:

PHP: 
Sub aktif()
    Application.EnableEvents = True
End Sub

Bulunamadı yazmaması için o iki satırdaki = "Bulunamadı" ifadeleri yerine .ClearContents ifadelerini kullanın.
Genişletmek için tıkla ...

Hocam aşağıdaki gibi hata veriyor. Nerede yanlış yapıyorum ?

234999
 
"=" yani "Eşittir" de silinecekti.
 
YUSUF44' Alıntı:
"=" yani "Eşittir" de silinecekti.
Genişletmek için tıkla ...

Hocam Merhaba,

Kusuruma bakmayın benim hatam :( Hem çalışıp hem de arada bunu da halletmeye çalışıyorum.

Şimdi bir şeyi daha fark ettim. Listede her zaman TC vatandaşları olmayacak. Yabancı vatandaşlarda olacak. Dolayısıyla bu kişilerin de bilgilerini listeden çekebilmek için en mantıklı yol doküman no sütunu. G2:G sütununa ek olarak J2:J yi de eklemek için kodlama da nasıl bir değişiklik yapmalıyım ?

Böylelikle TC vatandaşları için artama kriteri TC kimlik no (G2:G), yabancı vatandaşlar için ise doküman no (J2:J) olacak.

Syg,
 
Aşağıdaki gibi deneyin. G ya da J sütununda değişiklik yaptıkça işlem gerçekleşir. Yalnız çok düşük bir ihtimal de olsa farklı ülke vatandaşı olup aynı kimlik ya da döküman numarası olan kişilerde listedeki ilk kişinin bilgilerini getirir:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then GoTo 10
a = Target.Row
Set s1 = Sheets("Veri")
son = s1.Cells(Rows.Count, "G").End(3).Row
If Target = "" Then
    Application.EnableEvents = False
        Range("A" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("G1:G" & son), Target) > 0 Then
    Application.EnableEvents = False
        sat = WorksheetFunction.Match(Target, s1.Range("G1:G" & son), 0)
        s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Target.Select
    Application.EnableEvents = True
Else
    Application.EnableEvents = False
        Range("A" & a & ":F" & a).ClearContents
        Range("H" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
End If
10:
If Intersect(Target, Range("J2:J" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
Set s1 = Sheets("Veri")
son = s1.Cells(Rows.Count, "J").End(3).Row
If Target = "" Then
    Application.EnableEvents = False
        Range("A" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("J1:J" & son), Target) > 0 Then
    Application.EnableEvents = False
        sat = WorksheetFunction.Match(Target, s1.Range("J1:J" & son), 0)
        s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Target.Select
    Application.EnableEvents = True
Else
    Application.EnableEvents = False
        Range("A" & a & ":I" & a).ClearContents
        Range("K" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
End If
End Sub
 
.

Pratik bir yöntem.

Liste sayfanızı ister XLOOKUP, ister INDEX - MATCH ya da başka formüllerle yapın.

Sonra bu sayfayı Value=Değer olarak ikizini yapan aşağıdaki kodu kullanın.

Kod: 
Sub SayfaDegerKopya()

Worksheets("Liste").Copy After:=Worksheets("Liste")
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

End Sub

.
 

Ekli dosyalar

Son düzenleme:
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin. G ya da J sütununda değişiklik yaptıkça işlem gerçekleşir. Yalnız çok düşük bir ihtimal de olsa farklı ülke vatandaşı olup aynı kimlik ya da döküman numarası olan kişilerde listedeki ilk kişinin bilgilerini getirir:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then GoTo 10
a = Target.Row
Set s1 = Sheets("Veri")
son = s1.Cells(Rows.Count, "G").End(3).Row
If Target = "" Then
    Application.EnableEvents = False
        Range("A" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("G1:G" & son), Target) > 0 Then
    Application.EnableEvents = False
        sat = WorksheetFunction.Match(Target, s1.Range("G1:G" & son), 0)
        s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Target.Select
    Application.EnableEvents = True
Else
    Application.EnableEvents = False
        Range("A" & a & ":F" & a).ClearContents
        Range("H" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
End If
10:
If Intersect(Target, Range("J2:J" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
Set s1 = Sheets("Veri")
son = s1.Cells(Rows.Count, "J").End(3).Row
If Target = "" Then
    Application.EnableEvents = False
        Range("A" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("J1:J" & son), Target) > 0 Then
    Application.EnableEvents = False
        sat = WorksheetFunction.Match(Target, s1.Range("J1:J" & son), 0)
        s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Target.Select
    Application.EnableEvents = True
Else
    Application.EnableEvents = False
        Range("A" & a & ":I" & a).ClearContents
        Range("K" & a & ":L" & a).ClearContents
    Application.EnableEvents = True
End If
End Sub
Genişletmek için tıkla ...

Hocam çok teşekkür ederim , ellerinize sağlık.

Çözüldü olarak nereden işaretleyebilirim ?

Syg,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst