Şarta bağlı otomatik veri girişi (VBA)

[Sunaycakirr]

Merhabalar

Benim bir tablom var arkadaşlar. Bu tabloda yer alan 2.Sheette firmalara bir kod tanımlıyorum. 1.Sheete de takip için bir veri girişi yapıyorum. Benim istediğim şey ise şu;

1.Sheette A sütununa firma ismini yazdıktan sonra eğer B sütununda veri girişi var ise C sütununa o firmaya benim tanımlamış oluğum kodu otomatik getirsin. B sütunu boş ise C sütununu da boş bıraksın ben kendim istediğimi yazayım. Bunu Eğer ile yapabilirsin diyeceksiniz. Ben bunu VBA ile yapmak istiyorum ama beceremedim. yardımcı olabilir misiniz?

Dosya Linki;

İndir Yeni Microsoft Excel Çalışma Sayfası

Dosyayı indir Yeni Microsoft Excel Çalışma Sayfası

dosya.co

Çalışma örneği;

İndir Yeni Microsoft Excel Çalışma Sayfası

Dosyayı indir Yeni Microsoft Excel Çalışma Sayfası

dosya.co

 

[ÖmerBey]

Merhaba,
Tablo sayfasının kod bölümüne aşağıdaki kodu kopyalayıp deneyiniz...

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("B:B"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If WorksheetFunction.CountIf(Sayfa2.Range("A:A"), Target.Offset(0, -1).Text) = 0 Then
    MsgBox Target.Offset(0, -1).Text & " değeri " & Sayfa2.Name & " sayfasında bulunamadı.", vbCritical
Else
    Target.Offset(0, 1).Value = Sayfa2.Range("A:A").Find(Target.Offset(0, -1).Text).Offset(0, 1).Value
End If
End Sub

 

[Sunaycakirr]

Hocam istediğim oldu ancak ben a ve b sütununa anlık veri değişimleri veya silme yaptığımda c sütununun da anlık değişmesini istiyorum. Bu kodla ilk girdiğim gibi kalıyor silme yaptığımda c sütunu sabit kalıyor.

Merhaba,
Tablo sayfasının kod bölümüne aşağıdaki kodu kopyalayıp deneyiniz...

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("B:B"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If WorksheetFunction.CountIf(Sayfa2.Range("A:A"), Target.Offset(0, -1).Text) = 0 Then
    MsgBox Target.Offset(0, -1).Text & " değeri " & Sayfa2.Name & " sayfasında bulunamadı.", vbCritical
Else
    Target.Offset(0, 1).Value = Sayfa2.Range("A:A").Find(Target.Offset(0, -1).Text).Offset(0, 1).Value
End If
End Sub

 

[ÖmerBey]

If Target.Value = "" Then Exit Sub
satırını aşağıdaki ile değiştirirseniz b sütunundaki veriyi silince c sütunu da silinir.
If Target.Value = "" Then Target.Offset(0,1).ClearContents

 

[Sunaycakirr]

Hocam dosya linkte. Anlık değişim olmuyor.

İndir Yeni Microsoft Excel Çalışma Sayfası

Dosyayı indir Yeni Microsoft Excel Çalışma Sayfası

dosya.co

If Target.Value = "" Then Exit Sub
satırını aşağıdaki ile değiştirirseniz b sütunundaki veriyi silince c sütunu da silinir.
If Target.Value = "" Then Target.Offset(0,1).ClearContents

 

[ÖmerBey]

Doğrudur, haklısınız.
Denemeden ezberden yazmıştım, bir mantık hatası yapmışım...
Aşağıdaki şekilde deneyiniz...

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("B:B"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then
    Target.Offset(0, 1).ClearContents
ElseIf WorksheetFunction.CountIf(Sayfa2.Range("A:A"), Target.Offset(0, -1).Text) = 0 Then
    MsgBox Target.Offset(0, -1).Text & " değeri " & Sayfa2.Name & " sayfasında bulunamadı.", vbCritical
Else
    Target.Offset(0, 1).Value = Sayfa2.Range("A:A").Find(Target.Offset(0, -1).Text).Offset(0, 1).Value
End If
End Sub

 

[Sunaycakirr]

Ho

Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Range("B:B"), Target) Is Nothing Then Exit Sub If Target.Cells.Count > 1 Then Exit Sub If Target.Value = "" Then Target.Offset(0, 1).ClearContents ElseIf WorksheetFunction.CountIf(Sayfa2.Range("A:A"), Target.Offset(0, -1).Text) = 0 Then MsgBox Target.Offset(0, -1).Text & " değeri " & Sayfa2.Name & " sayfasında bulunamadı.", vbCritical Else Target.Offset(0, 1).Value = Sayfa2.Range("A:A").Find(Target.Offset(0, -1).Text).Offset(0, 1).Value End If End Sub

Hocam B sütununda yaptığım değişikliği görüp kodu çalıştırıyor. Ancak A sütununda yaptığım değişikliği kontrol etmiyor. Aynı B deki gibi kod tekrar çalışsın istiyorum

 

[ÖmerBey]

Tekrar merhaba,
Anlaşılan ben sizin isteğinizi eksik anlamışım, yanlış yönlendirdiğim için kusuruma bakmayın.
Dosyanızdaki kodları aşağıdaki kodlarla değiştirip yeniden deneyiniz.
İyi çalışmalar...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s As Long
If Not Intersect(Me.Range("A:B"), Target) Is Nothing Then
    s = Target.Row
    If Me.Cells(s, 1) = "" Or Me.Cells(s, 2) = "" Then
        Me.Cells(s, 3).ClearContents
    ElseIf WorksheetFunction.CountIf(Sayfa2.Range("A:A"), Me.Cells(s, 1).Text) = 0 Then
        MsgBox Me.Cells(s, 1).Text & " değeri " & Sayfa2.Name & " sayfasında bulunamadı.", vbCritical
    Else
        Me.Cells(s, 3).Value = Sayfa2.Range("A:A").Find(Me.Cells(s, 1).Text).Offset(0, 1).Value
    End If
End If
End Sub

 

[Sunaycakirr]

Private Sub Worksheet_Change(ByVal Target As Range) Dim s As Long If Not Intersect(Me.Range("A:B"), Target) Is Nothing Then s = Target.Row If Me.Cells(s, 1) = "" Or Me.Cells(s, 2) = "" Then Me.Cells(s, 3).ClearContents ElseIf WorksheetFunction.CountIf(Sayfa2.Range("A:A"), Me.Cells(s, 1).Text) = 0 Then MsgBox Me.Cells(s, 1).Text & " değeri " & Sayfa2.Name & " sayfasında bulunamadı.", vbCritical Else Me.Cells(s, 3).Value = Sayfa2.Range("A:A").Find(Me.Cells(s, 1).Text).Offset(0, 1).Value End If End If End Sub

Hocam Allah razı olsun. Ne muradın varsa versin Çok teşekkür ederim. Çok zahmet verdim hakkını helal et

 

[ÖmerBey]

Allah hepimizden razı olsun,
İyi çalışmalar...