Düşeyara makro ile "Yardım"!

[cenkozkurt]

Merhabalar,

Forumdaki düşeyara konularını inceledim ancak dosyama uygulayamadım. Yardım ederseniz sevinirim.

Userform açılışı : "Berechnung" kitabındaki - PP Start - Prozess 1 -Hinzufügen

Produkt(örnegin p123-p124) ve Stückzahl(sayı: 1,2,3,4..) kısmına yazılan ürünler direk "Berechnung"da a8 den itibaren .aşağıya yazılıyor.

Verileride "stammdaten" kitabından alıyor.

Yapmak istediğim "hinzufügen" tuşuna basıldığında a8:a20 arasındaki ürün numaralarının karsındaki ta,tr kısımlarını kendinin doldurması. Eğer girilen ürün "stammdaten" içerisinde de yok ise msgbox ile başka bir ürün girin yazılması. Yardımlarınızı bekliyorum. Şimdiden teşekkürler.

Not: Şuanda c8 hücresinde formül var, bu işlem formülle değil makro ile yapılmalı.

 

[Necdet]

Merhaba,

Tam olarak anlamamakla birlikte,

Aşağıdaki kodları "Berechnung" sayfasının kod bölümüne kopyalayın, inceleyip, kendinize göre uyarlayınız.
ilgili sayfanın a8:a20 aralığındaki hücrelerdeki değişiklik olduğunda kod çalışmaktadır.

Değeri sildiğinizde ya da değer bulunmadığında ilgili sayfadaki değerleri silmek gerekebilir. Ben sadece C ve E arasını sildim. Örneği genişletebilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [A8:A20]) Is Nothing Then Exit Sub
    On Error Resume Next
    
    Dim s1  As Worksheet, _
        c   As Range
    
    Set s1 = Sheets("stammdaten")
    If Target.Value = "" Then
        Range("C" & Target.Row & ":E" & Target.Row).ClearContents
        Exit Sub
    End If
    
    Set c = s1.Range("A:A").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        Target.Offset(0, 2) = s1.Range("B" & c.Row)
        Target.Offset(0, 3) = s1.Range("C" & c.Row)
        Target.Offset(0, 4) = s1.Range("C" & c.Row)
    Else
        MsgBox "GEÇERLİ BİR DEĞER GİRİNİZ", vbCritical, "HATALI GİRİŞ...."
    End If
        
End Sub

 

[cenkozkurt]

Merhaba,

Tam olarak anlamamakla birlikte,

Aşağıdaki kodları "Berechnung" sayfasının kod bölümüne kopyalayın, inceleyip, kendinize göre uyarlayınız.
ilgili sayfanın a8:a20 aralığındaki hücrelerdeki değişiklik olduğunda kod çalışmaktadır.

Değeri sildiğinizde ya da değer bulunmadığında ilgili sayfadaki değerleri silmek gerekebilir. Ben sadece C ve E arasını sildim. Örneği genişletebilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [A8:A20]) Is Nothing Then Exit Sub
    On Error Resume Next
    
    Dim s1  As Worksheet, _
        c   As Range
    
    Set s1 = Sheets("stammdaten")
    If Target.Value = "" Then
        Range("C" & Target.Row & ":E" & Target.Row).ClearContents
        Exit Sub
    End If
    
    Set c = s1.Range("A:A").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        Target.Offset(0, 2) = s1.Range("B" & c.Row)
        Target.Offset(0, 3) = s1.Range("C" & c.Row)
        Target.Offset(0, 4) = s1.Range("C" & c.Row)
    Else
        MsgBox "GEÇERLİ BİR DEĞER GİRİNİZ", vbCritical, "HATALI GİRİŞ...."
    End If
        
End Sub

Teşekkürler Necdet Bey, ancak çalışmadı ya da ben bir yerde yanlışlık yaptım. Basit olarak istediğim Berechnung(A2:A20) aralığına gelen değerlerin karşılığını Stammdaten kitabından bularak oraya taşıması.

 

[cenkozkurt]

Yardımcı olursanız sevinirim, hala yapamadım.