• DİKKAT

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

verileri koşullara göre aktarmak

eneskus' Alıntı:
Ellerine sağlık mükemmelsin. çalıştı.
ancak utanarak hattim olmayarak sölemek isterim dosyanın bir numara büyüğünü denedim 2 dk da hesapladı gercek dosya da ise 25 dk bekledim bitmedi malesef

ne yapmamız gerekmekte acaba

haddim olmayarak bir öneride bulunmak isterim
örnegin biz 2. satıra veri girmekteyiz u2,w2,y2,aa2,ac2,ae2 den herhangi birine veri girildiğinde 0 satır ile ilgili makro çalışarak miktar yazılır yazılmaz miktarı aktarsın

3. satıra gecilip u3,w3,y3,aa3,ac3,ae3 e mikarlar girildiğinde makro sadece 3. satırda işlm yapsa

makro işlemleri bölmüş oluruz bölelikle sorunu hallederiz diye düşünmekteyim sizin fikriniz nedir.
Genişletmek için tıkla ...

Merhaba
Bu problem sizin veri tabanınızdan kaynaklanmakta. Çok fazla sütunda arama yaptırmak zorunda kalıyoruz. Benden bu konuda bu kadar umarım diğer arkadaşlar yardımcı olurlar
 
asi_kral_1967' Alıntı:
Merhaba
Bu problem sizin veri tabanınızdan kaynaklanmakta. Çok fazla sütunda arama yaptırmak zorunda kalıyoruz. Benden bu konuda bu kadar umarım diğer arkadaşlar yardımcı olurlar
Genişletmek için tıkla ...

arkadaşım tekrardan teşekkürler ancak vaktin varsa eğer ilgilenmem mümkünmü konu geneline bakarsan sizden başka ilgilenen arkadaş yok malesef şimdilik

eğer birsefer daha yardımcı olacak vaktin varsa if ile örneğin u2:ae2 arasında veri var ise 2 satır da işlem yapsa yoksa 3. satıra geçse ordada yoksa..... bu şekilde makroya bir ilave yapmamız mümkünmü

ilgilenemeseniz bile ilgilendiğiniz yeter allah razı olsun sizden
 
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("T2:AE1201")) Is Nothing Then
    Call a1
  Else
  End If
End Sub
Sub a1()
'Konu       :   Malzeme Adına Göre Adet Bulma
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim S1 As Worksheet, S2 As Worksheet
Dim S1SAT As Long, S1SÜT As Long, _
S2SAT As Long, S2SÜT As Long
Set S1 = Sheets("VERİ")
Set S2 = Sheets("YENİ MALZEME MUTABAKATI")
S2.Range("D36:GO" & Rows.Count).ClearContents
Application.ScreenUpdating = False
For S2SAT = 36 To 36
For S2SÜT = 4 To 198
For S1SAT = 2 To 2
For S1SÜT = 20 To 32
If S1.Cells(1, S1SÜT) Like "*Malzemenin Cinsi*" Then
If S2.Cells(S2SAT, "A") = S1.Cells(S1SAT, "A") And _
S2.Cells(4, S2SÜT) = S1.Cells(S1SAT, S1SÜT) Then
S2.Cells(S2SAT, S2SÜT) = S1.Cells(S1SAT, S1SÜT + 1)
End If: End If: Next: Next: Next: Next
Application.ScreenUpdating = True
End Sub

Şeklinde kodu tek satırda çalışacak şekilde ayarladım ancak tüm satırlara tek tek eklemek zor.

Bu yüzden

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("T2:AE1201")) Is Nothing Then
    Call a1
  Else
  End If
End Sub
Sub a1()
'Konu       :   Malzeme Adına Göre Adet Bulma
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim S1 As Worksheet, S2 As Worksheet
Dim S1SAT As Long, S1SÜT As Long, _
S2SAT As Long, S2SÜT As Long
Set S1 = Sheets("VERİ")
Set S2 = Sheets("YENİ MALZEME MUTABAKATI")
S2.Range("D36:GO" & Rows.Count).ClearContents
Application.ScreenUpdating = False
For S2SAT = Cells(ActiveCell.Row + 34, 1) To Cells(ActiveCell.Row + 34, 1)
For S2SÜT = 4 To 198
For S1SAT = Cells(ActiveCell.Row, 1) To Cells(ActiveCell.Row, 1)
For S1SÜT = 20 To 32
If S1.Cells(1, S1SÜT) Like "*Malzemenin Cinsi*" Then
If S2.Cells(S2SAT, "A") = S1.Cells(S1SAT, "A") And _
S2.Cells(4, S2SÜT) = S1.Cells(S1SAT, S1SÜT) Then
S2.Cells(S2SAT, S2SÜT) = S1.Cells(S1SAT, S1SÜT + 1)
End If: End If: Next: Next: Next: Next
Application.ScreenUpdating = True
End Sub

Şeklinde kodu aktif olduğu hüçreye göre ayarlamaya çalıştım ama olmadı.


yardımlarınızı müteşekkir olurum.
 
Merhaba,

VERİ isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul_Satir As Range, Bul_Sutun As Range
    Dim Veri As Variant
    
    If Intersect(Target, Range("T2:AU" & Cells(Rows.Count, 1).End(3).Row)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target <> "" Then
        If Target.Column Mod 2 = 1 Then
            Veri = Target.Offset(0, -1)
        Else
            Veri = Target.Value
        End If
        
        Set S1 = Sheets("VERİ")
        Set S2 = Sheets("YENİ MALZEME MUTABAKATI")
        
        Set Bul_Satir = S2.Range("A:A").Find(Cells(Target.Row, 1), , , xlWhole)
        If Not Bul_Satir Is Nothing Then
            Set Bul_Sutun = S2.Range("D4:IV5").Find(Veri, , , xlWhole)
            If Not Bul_Sutun Is Nothing Then
                If Target.Column Mod 2 = 1 Then
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Value
                Else
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Offset(0, 1).Value
                End If
            End If
        End If
    End If
    
    Set Bul_Satir = Nothing
    Set Bul_Sutun = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 
Korhan Ayhan' Alıntı:
Merhaba,

VERİ isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul_Satir As Range, Bul_Sutun As Range
    Dim Veri As Variant
    
    If Intersect(Target, Range("T2:AU" & Cells(Rows.Count, 1).End(3).Row)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target <> "" Then
        If Target.Column Mod 2 = 1 Then
            Veri = Target.Offset(0, -1)
        Else
            Veri = Target.Value
        End If
        
        Set S1 = Sheets("VERİ")
        Set S2 = Sheets("YENİ MALZEME MUTABAKATI")
        
        Set Bul_Satir = S2.Range("A:A").Find(Cells(Target.Row, 1), , , xlWhole)
        If Not Bul_Satir Is Nothing Then
            Set Bul_Sutun = S2.Range("D4:IV5").Find(Veri, , , xlWhole)
            If Not Bul_Sutun Is Nothing Then
                If Target.Column Mod 2 = 1 Then
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Value
                Else
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Offset(0, 1).Value
                End If
            End If
        End If
    End If
    
    Set Bul_Satir = Nothing
    Set Bul_Sutun = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
Genişletmek için tıkla ...

Kodlar çalışmakta teşekkürler.

Ancak şöle bir sorun var veri sayfasında malzeme seçip adet girildikten sonra malzeme adı ve adedi sildiğimizde YENİ MALZEME MUTABAKATI sayfasında adet bilgileri silinmiyor aynı kalmakta bunu nasıl düzeltebiliriz.
 
Merhaba,

Bu durumda önceki önerdiğim kodu tamamen silip aşağıdaki kodu deneyin.

Not: Çoklu hücre seçip silerseniz doğru sonuç üretmez. Tek hücre seçimlerinde doğru sonuç üretir.

Kod: 
Dim Eski_Veri As Variant
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul_Satir As Range, Bul_Sutun As Range
    Dim Veri As Variant
    
    If Intersect(Target, Range("T2:AU" & Cells(Rows.Count, 1).End(3).Row)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MALZEME MUTABAKATI")
    
    If Target <> "" Then
        If Target.Column Mod 2 = 1 Then
            Veri = Target.Offset(0, -1)
        Else
            Veri = Target.Value
        End If
        
        Set Bul_Satir = S2.Range("A:A").Find(Cells(Target.Row, 1), , , xlWhole)
        If Not Bul_Satir Is Nothing Then
            Set Bul_Sutun = S2.Range("D4:IV5").Find(Veri, , , xlWhole)
            If Not Bul_Sutun Is Nothing Then
                If Target.Column Mod 2 = 1 Then
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Value
                Else
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Offset(0, 1).Value
                End If
            End If
        End If
    
    ElseIf Target = "" And Eski_Veri <> "" Then
        
        Set Bul_Satir = S2.Range("A:A").Find(Cells(Target.Row, 1), , , xlWhole)
        If Not Bul_Satir Is Nothing Then
            Set Bul_Sutun = S2.Range("D4:IV5").Find(Eski_Veri, , , xlWhole)
            If Not Bul_Sutun Is Nothing Then
                S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = ""
            End If
        End If
        
    End If
    
    Set Bul_Satir = Nothing
    Set Bul_Sutun = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("T2:AU" & Cells(Rows.Count, 1).End(3).Row)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target.Column Mod 2 = 1 Then
        Eski_Veri = Target.Offset(0, -1)
    Else
        Eski_Veri = Target.Value
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Merhaba,

Bu durumda önceki önerdiğim kodu tamamen silip aşağıdaki kodu deneyin.

Not: Çoklu hücre seçip silerseniz doğru sonuç üretmez. Tek hücre seçimlerinde doğru sonuç üretir.

Kod: 
Dim Eski_Veri As Variant
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul_Satir As Range, Bul_Sutun As Range
    Dim Veri As Variant
    
    If Intersect(Target, Range("T2:AU" & Cells(Rows.Count, 1).End(3).Row)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MALZEME MUTABAKATI")
    
    If Target <> "" Then
        If Target.Column Mod 2 = 1 Then
            Veri = Target.Offset(0, -1)
        Else
            Veri = Target.Value
        End If
        
        Set Bul_Satir = S2.Range("A:A").Find(Cells(Target.Row, 1), , , xlWhole)
        If Not Bul_Satir Is Nothing Then
            Set Bul_Sutun = S2.Range("D4:IV5").Find(Veri, , , xlWhole)
            If Not Bul_Sutun Is Nothing Then
                If Target.Column Mod 2 = 1 Then
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Value
                Else
                    S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = Target.Offset(0, 1).Value
                End If
            End If
        End If
    
    ElseIf Target = "" And Eski_Veri <> "" Then
        
        Set Bul_Satir = S2.Range("A:A").Find(Cells(Target.Row, 1), , , xlWhole)
        If Not Bul_Satir Is Nothing Then
            Set Bul_Sutun = S2.Range("D4:IV5").Find(Eski_Veri, , , xlWhole)
            If Not Bul_Sutun Is Nothing Then
                S2.Cells(Bul_Satir.Row, Bul_Sutun.Column) = ""
            End If
        End If
        
    End If
    
    Set Bul_Satir = Nothing
    Set Bul_Sutun = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("T2:AU" & Cells(Rows.Count, 1).End(3).Row)) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target.Column Mod 2 = 1 Then
        Eski_Veri = Target.Offset(0, -1)
    Else
        Eski_Veri = Target.Value
    End If
End Sub
Genişletmek için tıkla ...

Ellerinize sağlık cok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst