• DİKKAT

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

Data dan veri alma

O

ogrencı4

Altın Üye
Katılım
5 Kasım 2010
Mesajlar
40
Excel Vers. ve Dili
2010
Merhaba Arkadaşlar
ekte yer alan dosyada datadan veriyi buldurup liste-1 yazdırmak istiyorum.
alt alt olmadığı için formül ile yapamadım. liste baya geniş yardım edebilir misiniz.
teşekkürler.
 

Ekli dosyalar

Alternatif kod;

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

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SD As Worksheet, No_Bul As Range, Alan As Range, Onay As Byte, Mesaj As String
    
    On Error GoTo Son
        
    If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then Exit Sub
    
    If Target.Cells.CountLarge = 1 Then
        If Not IsEmpty(Target.Value) Then
            If WorksheetFunction.CountIf(Range("A:A"), Target.Value) > 1 Then
                MsgBox "Mükerrer kayıt girdiniz!" & Chr(10) & Chr(10) & "Girdiğiniz kayıt silinecektir!", vbCritical
                Target.Value = ""
                Target.Select
                Exit Sub
            End If
            Set SD = Sheets("DATA")
            Set No_Bul = SD.Cells.Find(Target.Value, , , xlWhole)
            If Not No_Bul Is Nothing Then
                Cells(Target.Row, 2) = No_Bul.Offset(0, 1)
                Cells(Target.Row, 3) = No_Bul.Offset(0, 2)
            Else
                MsgBox "Aşağıdaki kayıt bulunamadı!" & Chr(10) & Chr(10) & Target.Value, vbCritical
            End If
        End If
    Else
        For Each Alan In Selection
            If Not IsEmpty(Target.Value) Then
                If WorksheetFunction.CountIf(Range("A:A"), Alan.Value) > 1 Then
                    Onay = MsgBox("Çoklu veri girişinde mükerrer kayıtlar oluştu!" & Chr(10) & Chr(10) & _
                                  "Mükerrer kayıtların tümü sİlinecektir." & Chr(10) & Chr(10) & _
                                  "İşlemi onaylıyor musunuz?", vbCritical + vbYesNo)
                    If Onay = vbYes Then Selection.Value = ""
                    Exit Sub
                End If
                Set SD = Sheets("DATA")
                Set No_Bul = SD.Cells.Find(Alan.Value, , , xlWhole)
                If Not No_Bul Is Nothing Then
                    Cells(Alan.Row, 2) = No_Bul.Offset(0, 1)
                    Cells(Alan.Row, 3) = No_Bul.Offset(0, 2)
                Else
                    Mesaj = IIf(Mesaj = "", Alan.Value, Mesaj & " - " & Alan.Value)
                End If
            End If
        Next
        If Mesaj <> "" Then MsgBox "Aşağıdaki kayıtlar bulunamadı!" & Chr(10) & Chr(10) & Mesaj, vbCritical
    End If
Son:
    Set SD = Nothing
    Set No_Bul = Nothing
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif kod;

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

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SD As Worksheet, No_Bul As Range, Alan As Range, Onay As Byte, Mesaj As String
   
    On Error GoTo Son
       
    If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then Exit Sub
   
    If Target.Cells.CountLarge = 1 Then
        If Not IsEmpty(Target.Value) Then
            If WorksheetFunction.CountIf(Range("A:A"), Target.Value) > 1 Then
                MsgBox "Mükerrer kayıt girdiniz!" & Chr(10) & Chr(10) & "Girdiğiniz kayıt silinecektir!", vbCritical
                Target.Value = ""
                Target.Select
                Exit Sub
            End If
            Set SD = Sheets("DATA")
            Set No_Bul = SD.Cells.Find(Target.Value, , , xlWhole)
            If Not No_Bul Is Nothing Then
                Cells(Target.Row, 2) = No_Bul.Offset(0, 1)
                Cells(Target.Row, 3) = No_Bul.Offset(0, 2)
            Else
                MsgBox "Aşağıdaki kayıt bulunamadı!" & Chr(10) & Chr(10) & Target.Value, vbCritical
            End If
        End If
    Else
        For Each Alan In Selection
            If Not IsEmpty(Target.Value) Then
                If WorksheetFunction.CountIf(Range("A:A"), Alan.Value) > 1 Then
                    Onay = MsgBox("Çoklu veri girişinde mükerrer kayıtlar oluştu!" & Chr(10) & Chr(10) & _
                                  "Mükerrer kayıtların tümü sİlinecektir." & Chr(10) & Chr(10) & _
                                  "İşlemi onaylıyor musunuz?", vbCritical + vbYesNo)
                    If Onay = vbYes Then Selection.Value = ""
                    Exit Sub
                End If
                Set SD = Sheets("DATA")
                Set No_Bul = SD.Cells.Find(Alan.Value, , , xlWhole)
                If Not No_Bul Is Nothing Then
                    Cells(Alan.Row, 2) = No_Bul.Offset(0, 1)
                    Cells(Alan.Row, 3) = No_Bul.Offset(0, 2)
                Else
                    Mesaj = IIf(Mesaj = "", Alan.Value, Mesaj & " - " & Alan.Value)
                End If
            End If
        Next
        If Mesaj <> "" Then MsgBox "Aşağıdaki kayıtlar bulunamadı!" & Chr(10) & Chr(10) & Mesaj, vbCritical
    End If
Son:
    Set SD = Nothing
    Set No_Bul = Nothing
End Sub
Genişletmek için tıkla ...
teşekkürler hocam.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst