• DİKKAT

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

Yineleyen

T

TayfunKaya

Katılım
24 Mart 2019
Mesajlar
74
Excel Vers. ve Dili
2007 türkçe
https://www.dosyaupload.com/6adk

Arkadaşlar mobilim pc ye bağlanamıyorum bu yüzden ekran görüntüsü aldım. Örnekteki excelde O satırına 2 aynı ürün girildiği zaman, son girilen ürünün P sütunundaki değeri, ilk girilen aynı isimdeki ürünün P sütunundaki değerine eklenmesini ve daha sonra son girilen değerin silinemesini istiyorum. Çok karmaşık geldi ben yapamadım, makro veya formül olur farketmez mümkün müdür acaba?
 
Merhaba.
Aşağıdaki kodları işlem yaptığınız sayfanın kod kısmına yapıştırın.
Her O ve P kolonunda bir değişiklik olduğunda kodlar çalışıp istediğiniz kontrolü sağlayıp işlemi gerçekleştirecektir.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim R_Isim As Range
    Dim R_Adet As Range
    Dim Isim As String
    Dim Adet As Long
    Dim Bulunan As Range
    If Not Intersect(Target, Range("P:P")) Is Nothing And Not IsNumeric(Target.Value) Then
        MsgBox "Lütfen Adet kısmına geçerli bir rakam giriniz.", vbExclamation
        Target.ClearContents
        Target.Select
    End If
    If Intersect(Target, Range("O:P")) Is Nothing Then Exit Sub
    If Cells(Target.Row, "O") = "" Or Cells(Target.Row, "P") = "" Then Exit Sub
    Application.EnableEvents = False
    Set R_Isim = Cells(Target.Row, "O")
    Set R_Adet = Cells(Target.Row, "P")
    If WorksheetFunction.CountIf(Range("O:O"), R_Isim.Text) > 1 Then
        Adet = R_Adet.Value
        Isim = R_Isim.Value
        R_Isim.ClearContents
        R_Adet.ClearContents
        Set Bulunan = Range("O:O").Find(Isim)
        Bulunan(1, 2) = Bulunan(1, 2) + Adet
    End If
    Application.EnableEvents = True
End Sub
 
dalgalikur' Alıntı:
Merhaba.
Aşağıdaki kodları işlem yaptığınız sayfanın kod kısmına yapıştırın.
Her O ve P kolonunda bir değişiklik olduğunda kodlar çalışıp istediğiniz kontrolü sağlayıp işlemi gerçekleştirecektir.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim R_Isim As Range
    Dim R_Adet As Range
    Dim Isim As String
    Dim Adet As Long
    Dim Bulunan As Range
    If Not Intersect(Target, Range("P:P")) Is Nothing And Not IsNumeric(Target.Value) Then
        MsgBox "Lütfen Adet kısmına geçerli bir rakam giriniz.", vbExclamation
        Target.ClearContents
        Target.Select
    End If
    If Intersect(Target, Range("O:P")) Is Nothing Then Exit Sub
    If Cells(Target.Row, "O") = "" Or Cells(Target.Row, "P") = "" Then Exit Sub
    Application.EnableEvents = False
    Set R_Isim = Cells(Target.Row, "O")
    Set R_Adet = Cells(Target.Row, "P")
    If WorksheetFunction.CountIf(Range("O:O"), R_Isim.Text) > 1 Then
        Adet = R_Adet.Value
        Isim = R_Isim.Value
        R_Isim.ClearContents
        R_Adet.ClearContents
        Set Bulunan = Range("O:O").Find(Isim)
        Bulunan(1, 2) = Bulunan(1, 2) + Adet
    End If
    Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...
https://www.dosyaupload.com/6afc


Hocam örnek dosya üsttedir kodunuzu üzerinde uygular mısınız? Aynı hücrelere atanmış başka makrolar var bu yüzden hata veriyor olabilir
 
Telefonda mı problem var yoksa siteraltın üye değilim diye reklama mı boğuyor beni bilmem ama bir yazı gitmedi gösteriyor sonra tekrar gidiyor 2 farklı konu açmışım bu yüzden kusura bakmayın kasıtlı bişey yok
 
"EnvanterAlımı" adlı sayfanın kod bölümündeki kodların tamamını silin aşağıdakileri ekleyin.
Kodları test etme fırsatım olmadı kendiniz test edip geri dönüş yaparsınız.

Kod: 
Private Sub worksheet_selectionchange(ByVal Target As Range)
    If Intersect(Target, [O1:R100]) Is Nothing Then Exit Sub
    If Target.HasFormula Then
    Target.Offset(, 1).Select: End If
End Sub

Private Sub CommandButton1_Click()
    ARA = Range("I3").Text
    Set bul = ActiveSheet.Cells.Find(What:=ARA, After:=ActiveCell)
    If bul Is Nothing Then
        MsgBox "Bu Üründen Depoda Kalmamış Tayfun Bey"
    End If
    bul.Select
    Set bul = Nothing
End Sub

Private Sub CommandButton2_Click()
    Range("H3:L11").Select
    Selection.ClearContents
End Sub

Private Sub SİL_Click()
    Range("A3:D11").Select
    Selection.ClearContents
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C3:C11")) Is Nothing Then
        For i = 1 To Range("P65535").End(xlUp).Offset(1, 0).Row
            If Range("P" + CStr(i)).Value = "" Then
                Range("P" + CStr(i)).Value = Target.Value
                Exit For
            End If
        Next i
    End If

    If Not Intersect(Target, Range("B3:B11")) Is Nothing Then
        For i = 1 To Range("O65535").End(xlUp).Offset(1, 0).Row
            If Range("O" + CStr(i)).Value = "" Then
                Range("O" + CStr(i)).Value = Target.Value
                Exit For
            End If
        Next i
    End If
    If Not Intersect(Target, Range("D3:D11")) Is Nothing Then
        For i = 1 To Range("Q65535").End(xlUp).Offset(1, 0).Row
            If Range("Q" + CStr(i)).Value = "" Then
                Range("Q" + CStr(i)).Value = Target.Value
                Exit For
            End If
        Next i
    End If

    Dim R_Isim As Range
    Dim R_Adet As Range
    Dim Isim As String
    Dim Adet As Long
    Dim Bulunan As Range
    If Not Intersect(Target, Range("P:P")) Is Nothing And Not IsNumeric(Target.Value) Then
        MsgBox "Lütfen Adet kısmına geçerli bir rakam giriniz.", vbExclamation
        Target.ClearContents
        Target.Select
    End If
    If Intersect(Target, Range("O:P")) Is Nothing Then Exit Sub
    If Cells(Target.Row, "O") = "" Or Cells(Target.Row, "P") = "" Then Exit Sub
    Application.EnableEvents = False
    Set R_Isim = Cells(Target.Row, "O")
    Set R_Adet = Cells(Target.Row, "P")
    If WorksheetFunction.CountIf(Range("O:O"), R_Isim.Text) > 1 Then
        Adet = R_Adet.Value
        Isim = R_Isim.Value
        R_Isim.ClearContents
        R_Adet.ClearContents
        Set Bulunan = Range("O:O").Find(Isim)
        Bulunan(1, 2) = Bulunan(1, 2) + Adet
    End If
    Application.EnableEvents = True
End Sub
 
1- hocam kodlarda sorun yok ama fişi temizleyince kayıtlardan da siliniyor silinmemesi gerekir,
2- aynı isimdeki adetlerin toplanması ve isimlerin silinmesi çok güzel olmuş, birim fiyatı da silinse çok güzel olur.

çok teşekkür ederim.
 
Kod: 
Dim R_Isim As Range
    Dim R_Adet As Range
    Dim Isim As String
    Dim Adet As Long
    Dim Bulunan As Range
    If Not Intersect(target, Range("P:P")) Is Nothing And Not IsNumeric(target.Value) Then
        MsgBox "Lütfen Adet kısmına geçerli bir rakam giriniz.", vbExclamation
        target.ClearContents
        target.Select
    End If
    If Intersect(target, Range("O:P")) Is Nothing Then Exit Sub
    If Cells(target.Row, "O") = "" Or Cells(target.Row, "P") = "" Then Exit Sub
    Application.EnableEvents = False
    Set R_Isim = Cells(target.Row, "O")
    Set R_Adet = Cells(target.Row, "P")
    If WorksheetFunction.CountIf(Range("O:O"), R_Isim.Text) > 1 Then
        Adet = R_Adet.Value
        Isim = R_Isim.Value
        R_Isim.ClearContents
        R_Adet.ClearContents
        Set Bulunan = Range("O:O").Find(Isim)
        Bulunan(1, 2) = Bulunan(1, 2) + Adet
    End If
    Application.EnableEvents = True
 
TayfunKaya' Alıntı:
Kod: 
Dim R_Isim As Range
    Dim R_Adet As Range
    Dim Isim As String
    Dim Adet As Long
    Dim Bulunan As Range
    If Not Intersect(target, Range("P:P")) Is Nothing And Not IsNumeric(target.Value) Then
        MsgBox "Lütfen Adet kısmına geçerli bir rakam giriniz.", vbExclamation
        target.ClearContents
        target.Select
    End If
    If Intersect(target, Range("O:P")) Is Nothing Then Exit Sub
    If Cells(target.Row, "O") = "" Or Cells(target.Row, "P") = "" Then Exit Sub
    Application.EnableEvents = False
    Set R_Isim = Cells(target.Row, "O")
    Set R_Adet = Cells(target.Row, "P")
    If WorksheetFunction.CountIf(Range("O:O"), R_Isim.Text) > 1 Then
        Adet = R_Adet.Value
        Isim = R_Isim.Value
        R_Isim.ClearContents
        R_Adet.ClearContents
        Set Bulunan = Range("O:O").Find(Isim)
        Bulunan(1, 2) = Bulunan(1, 2) + Adet
    End If
    Application.EnableEvents = True
Genişletmek için tıkla ...
Hocam sizden 2 küçük ricam var, bu kodların içinden msgbox uyarısını kaldıralım çünkü formu temizleyince sonsuz hata döngüsüne giriyor o uyarı hiç olmasın "adet giriniz uyarısı".. 2.ricam ise size zahmet yineleyen isim olduğu zaman birim fiyatı kısmını da silebilir miyiz?
 
EnvanterAlımı adlısayfadaki kodları aşağıdakilerle değiştirin.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [O1:R100]) Is Nothing Then Exit Sub
    If Target.HasFormula Then
        Target.Offset(, 1).Select
    End If
End Sub

Private Sub CommandButton1_Click()
    ARA = Range("I3").Text
    Set bul = ActiveSheet.Cells.Find(What:=ARA, After:=ActiveCell)
    If bul Is Nothing Then
        MsgBox "Bu Üründen Depoda Kalmamış Tayfun Bey"
    End If
    bul.Select
    Set bul = Nothing
End Sub

Private Sub CommandButton2_Click()
    Range("H3:L11").ClearContents
End Sub

Private Sub SİL_Click()
    Range("A3:D11").ClearContents
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C3:C11")) Is Nothing Then
        For i = 1 To Range("P65535").End(xlUp).Offset(1, 0).Row
            If Range("P" + CStr(i)).Value = "" Then
                Range("P" + CStr(i)).Value = Target.Value
                Exit For
            End If
        Next i
    End If

    If Not Intersect(Target, Range("B3:B11")) Is Nothing Then
        For i = 1 To Range("O65535").End(xlUp).Offset(1, 0).Row
            If Range("O" + CStr(i)).Value = "" Then
                Range("O" + CStr(i)).Value = Target.Value
                Exit For
            End If
        Next i
    End If
    If Not Intersect(Target, Range("D3:D11")) Is Nothing Then
        For i = 1 To Range("Q65535").End(xlUp).Offset(1, 0).Row
            If Range("Q" + CStr(i)).Value = "" Then
                Range("Q" + CStr(i)).Value = Target.Value
                Exit For
            End If
        Next i
    End If
    Dim R_Isim As Range
    Dim R_Adet As Range
    Dim Isim As String
    Dim Adet As Long
    Dim Bulunan As Range
    If Intersect(Target, Range("O:P")) Is Nothing Then Exit Sub
    If Cells(Target.Row, "O") = "" Or Cells(Target.Row, "P") = "" Then Exit Sub
    Application.EnableEvents = False
    Set R_Isim = Cells(Target.Row, "O")
    Set R_Adet = Cells(Target.Row, "P")
    If WorksheetFunction.CountIf(Range("O:O"), R_Isim.Text) > 1 Then
        Adet = R_Adet.Value
        Isim = R_Isim.Value
        R_Isim.ClearContents
        R_Adet.ClearContents
        Cells(Target.Row, "Q").ClearContents
        Set Bulunan = Range("O:O").Find(Isim)
        Bulunan(1, 2) = Bulunan(1, 2) + Adet
    End If
    Application.EnableEvents = True
End Sub
 
hocam uyarı kalkmış elinize sağlık ama birim fiyatı halen duruyor onu kaldıramadım..
 
aslında soldaki hücresi boş ise silinse de yeterli bu yolda işimi görür hocam
 
Birim fiyatını da silecek şekilde kod eklemiştim. Şimdi test ettim istediğiniz gibi birim fiyatı da siliniyor.
 
hocam yeni kayıt girildiği zaman siliyor birimi evet şimdi farkettim elinize sağlık. Müsait bir zamanda başka bir yaardım daha istesem? aynı bunun gibi.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst