• DİKKAT

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

Bir değer daha nasıl eklerim

Y

yousemeti

Katılım
4 Ocak 2007
Mesajlar
27
Excel Vers. ve Dili
2003 vb
Selamlar Degerli hocalarım,
D ye kadar almasını istiyorum

Range("D" & [C65536].End(3).Row + 1).Select
ama olmadı nerede hata yapıyorum


Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub

If Target.Value = "" Then Exit Sub

If Target.Value Like "CAR*" Then
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
Selection.Copy
Sheets("CARLA").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("C" & [C65536].End(3).Row + 1).Select
End If

If Target.Value Like "HOT*" Then
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
Selection.Copy
Sheets("HOTLINE").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("C" & [C65536].End(3).Row + 1).Select
End If

If Target.Value Like "IPTAL*" Then
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
Selection.Copy
Sheets("IPTAL").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("C" & [C65536].End(3).Row + 1).Select
End If

End Sub
 

Ekli dosyalar

yousemeti' Alıntı:
Selamlar Degerli hocalarım,
D ye kadar almasını istiyorum

Range("D" & [C65536].End(3).Row + 1).Select
ama olmadı nerede hata yapıyorum


Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub

If Target.Value = "" Then Exit Sub

If Target.Value Like "CAR*" Then
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
Selection.Copy
Sheets("CARLA").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("C" & [C65536].End(3).Row + 1).Select
End If

If Target.Value Like "HOT*" Then
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
Selection.Copy
Sheets("HOTLINE").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("C" & [C65536].End(3).Row + 1).Select
End If

If Target.Value Like "IPTAL*" Then
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
Selection.Copy
Sheets("IPTAL").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("C" & [C65536].End(3).Row + 1).Select
End If

End Sub
Genişletmek için tıkla ...

Merhaba
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
satırlarını
Range(Target.Offset(0, -2), Target.Offset(0, 1)).Select
Şeklinde değiştirip denermisiniz
 
Bu satırı
Kod: 
Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
bu satır ile değiştirip deneyiniz...
Kod: 
Cells(Target.Row, 1).Resize(, 4).Select
 
Afedersiniz Numan Bey, mesajınızı görmedim. :(
 
Aşağıdaki gibi sayfa adlarını ekleyerek deneyin.

Kod: 
 Private Sub Worksheet_Change(ByVal Target As Range)

'On Error Resume Next

If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub
    
    If Target.Value = "" Then Exit Sub
    
        If Target.Value Like "CAR*" Then
            Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
            Selection.Copy
            Sheets("CARLA").Select
            Sheets("CARLA").Range("A" & Sheets("CARLA").[A65536].End(3).Row + 1).Select
            ActiveSheet.Paste
            Sheets("GENEL").Select
            Application.CutCopyMode = False
            Sheets("GENEL").Range("D" & [C65536].End(3).Row + 1).Select
        End If
        
        If Target.Value Like "HOT*" Then
            Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
            Selection.Copy
            Sheets("HOTLINE").Select
            Sheets("HOTLINE").Range("A" & Sheets("HOTLINE").[A65536].End(3).Row + 1).Select
            ActiveSheet.Paste
            Sheets("GENEL").Select
            Application.CutCopyMode = False
            Sheets("GENEL").Range("D" & [C65536].End(3).Row + 1).Select
        End If

        If Target.Value Like "IPTAL*" Then
            Range(Target.Offset(0, 0), Target.Offset(0, -2)).Select
            Selection.Copy
            Sheets("IPTAL").Select
             Sheets("IPTAL").Range("A" & Sheets("IPTAL").[A65536].End(3).Row + 1).Select
            ActiveSheet.Paste
            Sheets("GENEL").Select
            Application.CutCopyMode = False
            Sheets("GENEL").Range("D" & [C65536].End(3).Row + 1).Select
        End If
       
End Sub
 
Son düzenleme:
Numan Bey Murat bey teşekür ederim. yardımlarınız. için
kodu degiştirdim hepsini dediginiz gibi ikinizzinde kodu aynı işi yapıyor test ettim.

yanlz bendeki bu ilk if c:c degiştiği zaman işi bitiriyor satırdan atıyor giriş yapaken
If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub

bu ilk if i neteye yazmam gerekiyorki satırda iş bittigi zaman copyalasın diger ilgili sayfalara

//kod

On Error Resume Next

If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub

If Target.Value = "" Then Exit Sub

If Target.Value Like "CAR*" Then
Cells(Target.Row, 1).Resize(, 4).Select
Selection.Copy
Sheets("CARLA").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("D" & [D65536].End(3).Row + 1).Select
End If

If Target.Value Like "HOT*" Then
Cells(Target.Row, 1).Resize(, 4).Select
Selection.Copy
Sheets("HOTLINE").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("D" & [D65536].End(3).Row + 1).Select
End If

If Target.Value Like "IPTAL*" Then
Cells(Target.Row, 1).Resize(, 4).Select
Selection.Copy
Sheets("IPTAL").Select
Range("A" & [A65536].End(3).Row + 1).Select
ActiveSheet.Paste
Sheets("GENEL").Select
Application.CutCopyMode = False
Range("D" & [D65536].End(3).Row + 1).Select
End If

End Sub
 
yousemeti' Alıntı:
Numan Bey Murat bey teşekür ederim. yardımlarınız. için
kodu degiştirdim hepsini dediginiz gibi ikinizzinde kodu aynı işi yapıyor test ettim.

yanlz bendeki bu ilk if c:c degiştiği zaman işi bitiriyor satırdan atıyor giriş yapaken
If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub

bu ilk if i neteye yazmam gerekiyorki satırda iş bittigi zaman copyalasın diger ilgili sayfalara
Genişletmek için tıkla ...

Aynı işi yapması normal.

Ben bu son sorunuzu anlamadım. :dusun::dusun::dusun:
 
acıklamaya calısayım,

örnek veriyorum a1 veri girdim b1 e veri girdim c1 veriyi girdigim an macro calsıısyor ve
kopyalama işini yapıyor ama benim yapmaya calısdıgım sey d1 de veri girdikten sonra kodlar calısması lazım. If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub
burada
Kod: 
Is Nothing Then Exit Sub
diyor ve kesiyor. ben vb kodlarını bilmiyorum web tabanlı yazılım yazıyorum. o yuzden mantık yuruterek yapmaya calsıısyorum hatalarım olabilir affınıza sıgınıyorum ustatlar.
 
Kodlarınızı bu kodlarla değiştirip deneyiniz;
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 4 And Target.Value = "" Then Exit Sub
        If Target.Value Like "CAR*" Then
            Cells(Target.Row, 1).Resize(, 4).Copy Sheet2.Range("A65536").End(3)(2, 1)
        ElseIf Target.Value Like "HOT*" Then
            Cells(Target.Row, 1).Resize(, 4).Copy Sheet3.Range("A65536").End(3)(2, 1)
        ElseIf Target.Value Like "IPTAL*" Then
            Cells(Target.Row, 1).Resize(, 4).Copy Sheet4.Range("A65536").End(3)(2, 1)
        End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst