Sayfa olayları / bul, kaydır,

W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
675
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Liste")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
sonsat2 = Cells(Rows.Count, "C").End(xlUp).Row

For i = 2 To sonsat2
    Set k = sh.Range("A2:A" & sonsat1).Find(Cells(i, "C").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(i, "D").Value = k.Offset(0, 1).Value
        Cells(i, "E").Value = k.Offset(0, 4).Value
    End If
Next i
End Sub

Merhaba,

Ekli dosyada şöylesi birşey yapmaya çalışmaktayım;

Deneme adlı excel sayfasında C sütununda herhangi bir hücreye veri girdiğimde Liste adlı sayfanın B sütunu ve E sütunu verilerini deneme adlı sayfadaki D ve E sütunlarına getirmek istiyorum. Liste adlı sayfanın A sütunu, deneme adlı sütunun C sütunu Ürün Kodu olmakta. Bunu deneme adlı sayfanın change kod kısmına nasıl yapabilirim. İlgili kodlar sayın oriona ait, kendi dosyama uyarlamak istiyorum.

deneme adlı sayfanın C sütununda bir hücreye ürün kodu girdiğimde Liste adlı sayfadan ilgili kodun yanındaki d,ğer bası bilgileri getirmeye çalışmaktayım.
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki kodu deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C2:C1000]) Is Nothing Then Exit Sub

Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Liste")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
a = Target.Row
If Target = "" Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
ElseIf WorksheetFunction.CountIf(sh.Range("A1:A" & sonsat1), Target) = 0 Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
    MsgBox "Aranan barkod bulunamadı!", vbExclamation, "Ürün yok"
    Exit Sub
Else
    Target.Offset(0, 1) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 2, 0)
    Target.Offset(0, 2) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 5, 0)
End If
End Sub
 
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
675
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
YUSUF44' Alıntı:
Aşağıdaki kodu deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C2:C1000]) Is Nothing Then Exit Sub

Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Liste")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
a = Target.Row
If Target = "" Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
ElseIf WorksheetFunction.CountIf(sh.Range("A1:A" & sonsat1), Target) = 0 Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
    MsgBox "Aranan barkod bulunamadı!", vbExclamation, "Ürün yok"
    Exit Sub
Else
    Target.Offset(0, 1) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 2, 0)
    Target.Offset(0, 2) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 5, 0)
End If
End Sub
Genişletmek için tıkla ...
 
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
675
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
YUSUF44' Alıntı:
Aşağıdaki kodu deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C2:C1000]) Is Nothing Then Exit Sub

Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Liste")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
a = Target.Row
If Target = "" Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
ElseIf WorksheetFunction.CountIf(sh.Range("A1:A" & sonsat1), Target) = 0 Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
    MsgBox "Aranan barkod bulunamadı!", vbExclamation, "Ürün yok"
    Exit Sub
Else
    Target.Offset(0, 1) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 2, 0)
    Target.Offset(0, 2) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 5, 0)
End If
End Sub
Genişletmek için tıkla ...
Yusuf bey merhaba,

Verdiğiniz kod istediğim sonucu vermekte. Ancak şöylesi biri durum var. Aynı sayfa altında iki faklı alan işlemi yapmaya çalışıyorum. yada iki farklı intersect olayı. Biri A sütunu diğeri C sütunu için. Sizin verdiğiniz kodlar C sütunu içinde. A sütunu için olan kodları eklememiştim. Sayfa kod kısmına kodları ayrı ayrı yerleştirdiğimde kodlar istediğim sonuçları veriyor ancak tek bir change altında olduğunda hata alıyorum ya da kodların biri çalışmıyor. Bunu nasıl düzeltebilirim. Diğer kodlar şöyle,

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

sonsatir = Sheets("İşlem_Türü").[a65536].End(3).Row + 1

If Target.Cells.Count > 1 Then Exit Sub
If Not UserForm1.ListBox1.Tag = "off" Then
If Intersect(Target, Range("A2:A10000")) Is Nothing Then Exit Sub
Dim deger As Range
sayac = 0
derlenen = Target.Address

bakilan = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))


For Each deger In Sheets("İşlem_Türü").Range("A2:A" & sonsatir)

If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then

    sayac = sayac + 1
    sonuc = deger.Value
    
    If sayac = 1 Then
    UserForm1.ListBox1.Clear
    End If
    
    UserForm1.ListBox1.AddItem deger.Value

End If

Next


If sayac > 1 Then
UserForm1.Tag = derlenen
UserForm1.Caption = "Birden Cok Uygun Kayit Var, Lutfen Birini Seciniz"
UserForm1.ListBox1.Tag = "off"

UserForm1.Show

UserForm1.ListBox1.Tag = ""

ElseIf sayac = 1 Then
UserForm1.ListBox1.Tag = "off"
Range(derlenen) = sonuc

Else

UserForm1.ListBox1.Tag = "off"
bakilan = ""
sayac = 0
For Each deger In Sheets("İşlem_Türü").Range("A2:A" & sonsatir)

If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then

    sayac = sayac + 1
    sonuc = deger.Value
    
    If sayac = 1 Then
    UserForm1.ListBox1.Clear
    End If
    
    UserForm1.ListBox1.AddItem deger.Value

End If

Next
UserForm1.Tag = derlenen
UserForm1.Caption = "Uygun Kayit Bulunamadi, Lutfen Listeden Birini Seciniz"
Range(derlenen) = ""
UserForm1.Show
End If
Else
UserForm1.ListBox1.Tag = ""
End If
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Böylece sorulan sorularda asıl dosyayla aynı yapıda örnek dosya paylaşmanın önemini anlamış oldunuz. ;)

Aşağıdaki kodları deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:A10000")) Is Nothing Then GoTo 10
sonsatir = Sheets("İşlem_Türü").[a65536].End(3).Row + 1
If Target.Cells.Count > 1 Then Exit Sub
If Not UserForm1.ListBox1.Tag = "off" Then
    Dim deger As Range
    sayac = 0
    derlenen = Target.Address
    bakilan = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
    For Each deger In Sheets("İşlem_Türü").Range("A2:A" & sonsatir)
        If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then
            sayac = sayac + 1
            sonuc = deger.Value
            If sayac = 1 Then
                UserForm1.ListBox1.Clear
            End If
            UserForm1.ListBox1.AddItem deger.Value
        End If
    Next
    If sayac > 1 Then
        UserForm1.Tag = derlenen
        UserForm1.Caption = "Birden Cok Uygun Kayit Var, Lutfen Birini Seciniz"
        UserForm1.ListBox1.Tag = "off"
        UserForm1.Show
        UserForm1.ListBox1.Tag = ""
    ElseIf sayac = 1 Then
        UserForm1.ListBox1.Tag = "off"
        Range(derlenen) = sonuc
    Else
        UserForm1.ListBox1.Tag = "off"
        bakilan = ""
        sayac = 0
        For Each deger In Sheets("İşlem_Türü").Range("A2:A" & sonsatir)
            If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then
                sayac = sayac + 1
                sonuc = deger.Value
                If sayac = 1 Then
                    UserForm1.ListBox1.Clear
                End If
                UserForm1.ListBox1.AddItem deger.Value
            End If
        Next
        UserForm1.Tag = derlenen
        UserForm1.Caption = "Uygun Kayit Bulunamadi, Lutfen Listeden Birini Seciniz"
        Range(derlenen) = ""
        UserForm1.Show
    End If
Else
    UserForm1.ListBox1.Tag = ""
End If
10:
If Intersect(Target, [C2:C1000]) Is Nothing Then Exit Sub

Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Liste")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
a = Target.Row
If Target = "" Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
ElseIf WorksheetFunction.CountIf(sh.Range("A1:A" & sonsat1), Target) = 0 Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
    MsgBox "Aranan barkod bulunamadı!", vbExclamation, "Ürün yok"
    Exit Sub
Else
    Target.Offset(0, 1) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 2, 0)
    Target.Offset(0, 2) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 5, 0)
End If
End Sub
 
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
675
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
YUSUF44' Alıntı:
Böylece sorulan sorularda asıl dosyayla aynı yapıda örnek dosya paylaşmanın önemini anlamış oldunuz. ;)

Aşağıdaki kodları deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:A10000")) Is Nothing Then GoTo 10
sonsatir = Sheets("İşlem_Türü").[a65536].End(3).Row + 1
If Target.Cells.Count > 1 Then Exit Sub
If Not UserForm1.ListBox1.Tag = "off" Then
    Dim deger As Range
    sayac = 0
    derlenen = Target.Address
    bakilan = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
    For Each deger In Sheets("İşlem_Türü").Range("A2:A" & sonsatir)
        If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then
            sayac = sayac + 1
            sonuc = deger.Value
            If sayac = 1 Then
                UserForm1.ListBox1.Clear
            End If
            UserForm1.ListBox1.AddItem deger.Value
        End If
    Next
    If sayac > 1 Then
        UserForm1.Tag = derlenen
        UserForm1.Caption = "Birden Cok Uygun Kayit Var, Lutfen Birini Seciniz"
        UserForm1.ListBox1.Tag = "off"
        UserForm1.Show
        UserForm1.ListBox1.Tag = ""
    ElseIf sayac = 1 Then
        UserForm1.ListBox1.Tag = "off"
        Range(derlenen) = sonuc
    Else
        UserForm1.ListBox1.Tag = "off"
        bakilan = ""
        sayac = 0
        For Each deger In Sheets("İşlem_Türü").Range("A2:A" & sonsatir)
            If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then
                sayac = sayac + 1
                sonuc = deger.Value
                If sayac = 1 Then
                    UserForm1.ListBox1.Clear
                End If
                UserForm1.ListBox1.AddItem deger.Value
            End If
        Next
        UserForm1.Tag = derlenen
        UserForm1.Caption = "Uygun Kayit Bulunamadi, Lutfen Listeden Birini Seciniz"
        Range(derlenen) = ""
        UserForm1.Show
    End If
Else
    UserForm1.ListBox1.Tag = ""
End If
10:
If Intersect(Target, [C2:C1000]) Is Nothing Then Exit Sub

Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Liste")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
a = Target.Row
If Target = "" Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
ElseIf WorksheetFunction.CountIf(sh.Range("A1:A" & sonsat1), Target) = 0 Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
    MsgBox "Aranan barkod bulunamadı!", vbExclamation, "Ürün yok"
    Exit Sub
Else
    Target.Offset(0, 1) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 2, 0)
    Target.Offset(0, 2) = WorksheetFunction.VLookup(Target, sh.Range("A1:E" & sonsat1), 5, 0)
End If
End Sub
Genişletmek için tıkla ...

Yusuf Bey, teşekkürler,

Uyarınızda haklısınız, kuru kalabalık olmasın diye ilk kodları belirtmemiştim.

Kolaylıklar,
 
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
675
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Dosyanın son hali ektedir, örnek olması amacıyla yüklüyorum.
 

Ekli dosyalar

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