veri aktarımında 2 satır ve 2 sütunu silmesin

[aslan1969]

selemlar
giriş sayfasından veri aktarımı yapıyorum
veri aktarılan sayfada 2. ve 3. satırın ve L ile M sütununun
formüleri ve bilgileri silinmesin onları pas geçsin
acaba mümkünmüdür
teşekkür ederim

 

[aslan1969]

örnek dosya ektedir

 

[aslan1969]

birtürlü ekliyemedim acaba xlsm office 2007 uzantısı olduğundanmı
2003 belgesine çevirip birdaha ekliyorum

 

[aslan1969]

yardımcı olabilirmisiniz
teşekkür ederim

 

[Ferhat Pazarçevirdi]

Kodlarınızı aşağıdaki gibi revize edin.

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If ActiveCell.Row = 1 Then Exit Sub '-- 1. Satır Başlık olduğunu varsayarak işlem dışı bırakılmıştır
Sayfa_Adi = Cells(ActiveCell.Row, "D") 'Çift Tıklanan Satırın A sütununun Adını Sayfa_Adi değişkenine aktarılıyor
If Sayfa_Adi = "" Then Exit Sub        'Boş Satırda çift tıklandığında işlemi dikkate alma
Var = 0                                 ' Var değişkenine Sıfır Atanıyor
Adet = 0
For i = 2 To Worksheets.Count           'Daha önce sayfa varsa onun kontrolünün döngüsü
    If Sheets(i).Name = Sayfa_Adi Then  'eşitliği kontrol ediliyor
       Var = 1                          'Eşitse Var değişkenine 1 Atanıyor
       Exit For                         'Döngüden çıkış sağlanıyor
       End If                           'Karşılaştırmanın Sonu
Next                                    'Döngünün Sonu
    
If Var = 0 Then                         'İlgili Sayfa yoksa, o adla sayfa oluşturuluyor
   Worksheets.Add after:=Worksheets(Worksheets.Count)
   ActiveSheet.Name = Sayfa_Adi
   End If
   
Sheets("Sayfa1").Select                 'Sayfa1 seçiliyor
If Var = 0 Then i = Worksheets.Count    'Var değişkeni 0 ise i nin değerini Sayfasayısını i değişkenine aktar
Set S2 = Sheets(i)                      'Eğer ilgili sayfa varsa i değişkeni daha önce bulunmuştu, i değişkeni ilgili sayfanın kaçıncı sayfa adedi olduğunu belirtiyor
S2.Cells.ClearContents                  'aktarılacak sayfayı boşaltılıyor
K = 1                                   'J değişkenine 1 aktarılıyor, bu aktarılacak sayfada 1. satırın başlık olduğunu düşünerek 1 atanmıştır
Range("A1:K1").Copy S2.[A1]             'aktarılacak sayfaya başlığın aktarılması
[COLOR=red]S2.Range("J2").Formula = "=SUM(J3:J983)"
S2.Range("J3").Formula = "4500"
S2.Range("k2").Formula = "=SUM(k3:K983)"
S2.Range("f3") = "DEVİR ALACAK"[/COLOR]
 
For i = 2 To [f65536].End(3).Row        'Aktarılacak satırların seçimi için döngü oluşturuluyor
    If Cells(i, "D") = Sayfa_Adi Then   'A sütunu Sayfa_adi değişkenine eşitse karşılaştırılması yapılıyor
[COLOR=red]'        K = K + 1                           'J değişkenine 1 aktarılarak bilgiler[/COLOR] aktarılıyor
        Adet = Adet + 1                     'Kaç satır aktardığımızı anlamak için tutulan değişken
[COLOR=red]        S2.Cells(i + 2, "A") = Cells(i, "A") 'Sütunlar Teker teker aktarılıyor
        S2.Cells(i + 2, "B") = Cells(i, "B")
        S2.Cells(i + 2, "C") = Cells(i, "C")
        S2.Cells(i + 2, "D") = Cells(i, "D")
        S2.Cells(i + 2, "E") = Cells(i, "E")
        S2.Cells(i + 2, "F") = Cells(i, "F")
        S2.Cells(i + 2, "G") = Cells(i, "G")
        S2.Cells(i + 2, "H") = Cells(i, "H")
        S2.Cells(i + 2, "I") = Cells(i, "I")
        S2.Cells(i + 2, "J") = Cells(i, "J")
        S2.Cells(i + 2, "K") = Cells(i, "K")
[/COLOR]    End If                                  'Karşılaştırmanın Sonu
Next                                        'Döngünün Sonu
If Adet > 0 Then                            'Adet Değişkeni Sıfırdan farklı ise, aktarım sağlanmıştır, bunun mesajı veriliyor
    MsgBox Sayfa_Adi & " Sayfasına " & Adet & " Adet Kayıt Aktarılmıştır"
End If
End Sub

 

[aslan1969]

selamlar
yardımlarınız için çok teşekkür ederim
örneğimi değiştirerek birdaha ekliyorum çünkü
giriş sayfasında birkaç firma olduğunda firmaların bilgilerini
sayfasına alt alta atmıyor birde L ve M sütunlarındada aynı şeyi uyguluyabilirmiyiz
çok teşekkür ederim
saygılarımla

 

[Ferhat Pazarçevirdi]

O halde, kodlarınızı şu şekilde değiştiriniz.

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If ActiveCell.Row = 1 Then Exit Sub '-- 1. Satır Başlık olduğunu varsayarak işlem dışı bırakılmıştır
Sayfa_Adi = Cells(ActiveCell.Row, "D") 'Çift Tıklanan Satırın A sütununun Adını Sayfa_Adi değişkenine aktarılıyor
If Sayfa_Adi = "" Then Exit Sub        'Boş Satırda çift tıklandığında işlemi dikkate alma
Var = 0                                 ' Var değişkenine Sıfır Atanıyor
adet = 0
For i = 2 To Worksheets.Count           'Daha önce sayfa varsa onun kontrolünün döngüsü
    If Sheets(i).Name = Sayfa_Adi Then  'eşitliği kontrol ediliyor
       Var = 1                          'Eşitse Var değişkenine 1 Atanıyor
       Exit For                         'Döngüden çıkış sağlanıyor
       End If                           'Karşılaştırmanın Sonu
Next                                    'Döngünün Sonu
    
If Var = 0 Then                         'İlgili Sayfa yoksa, o adla sayfa oluşturuluyor
   Worksheets.Add after:=Worksheets(Worksheets.Count)
   ActiveSheet.Name = Sayfa_Adi
   End If
   
Sheets("Sayfa1").Select                 'Sayfa1 seçiliyor
If Var = 0 Then i = Worksheets.Count    'Var değişkeni 0 ise i nin değerini Sayfasayısını i değişkenine aktar
Set s2 = Sheets(i)                      'Eğer ilgili sayfa varsa i değişkeni daha önce bulunmuştu, i değişkeni ilgili sayfanın kaçıncı sayfa adedi olduğunu belirtiyor
[COLOR=red]s2.Unprotect[/COLOR]
s2.Cells.ClearContents                  'aktarılacak sayfayı boşaltılıyor
[COLOR=red]K = 3[/COLOR]                                   'J değişkenine 1 aktarılıyor, bu aktarılacak sayfada 1. satırın başlık olduğunu düşünerek 1 atanmıştır
Range("A1:K1").Copy s2.[A1]             'aktarılacak sayfaya başlığın aktarılması
 
For i = 2 To [f65536].End(3).Row        'Aktarılacak satırların seçimi için döngü oluşturuluyor
    If Cells(i, "D") = Sayfa_Adi Then   'A sütunu Sayfa_adi değişkenine eşitse karşılaştırılması yapılıyor
[COLOR=red]        K = K + 1[/COLOR]                           'J değişkenine 1 aktarılarak bilgiler aktarılıyor
        adet = adet + 1                     'Kaç satır aktardığımızı anlamak için tutulan değişken
[COLOR=red]        s2.Cells(K, "A") = Cells(i, "A") 'Sütunlar Teker teker aktarılıyor
        s2.Cells(K, "B") = Cells(i, "B")
        s2.Cells(K, "C") = Cells(i, "C")
        s2.Cells(K, "D") = Cells(i, "D")
        s2.Cells(K, "E") = Cells(i, "E")
        s2.Cells(K, "F") = Cells(i, "F")
        s2.Cells(K, "G") = Cells(i, "G")
        s2.Cells(K, "H") = Cells(i, "H")
        s2.Cells(K, "I") = Cells(i, "I")
        s2.Cells(K, "J") = Cells(i, "J")
        s2.Cells(K, "K") = Cells(i, "K")[/COLOR]
    End If                                  'Karşılaştırmanın Sonu
Next                                        'Döngünün Sonu
s2.Range("J2").Formula = "=SUM(J3:J983)"
s2.Range("J3").Formula = "4500"
s2.Range("k2").Formula = "=SUM(k3:K983)"
s2.Range("L2").Formula = "=J2-K2"
s2.Range("f3") = "DEVİR ALACAK"
[COLOR=red]s2.Range("A4:K" & adet + 3).Locked = False
s2.Protect[/COLOR]
If adet > 0 Then                            'Adet Değişkeni Sıfırdan farklı ise, aktarım sağlanmıştır, bunun mesajı veriliyor
    MsgBox Sayfa_Adi & " Sayfasına " & adet & " Adet Kayıt Aktarılmıştır"
End If
End Sub

 

[aslan1969]

teşekkür

selamlar
süper oldu
elleriniz dert görmesin
teşekkür ederim
saygılar