Başka sayfaya mükerrer kopyalama

[tirEdsOuL]

Arkadaşlar Merhaba;

Emir Hüseyin Çoban hocamızın desteğiyle aşağıdaki kod ile bazı sayfalardan A sütununda filtreleme yaparak mail gönderimi yapıyordum. Kodda ufak tefek bazı düzeltmeler yapmıştım ve gayet sağlıklı çalışıyordu. Ama bugünden itibaren "mail için" sayfasına kopyaladığı alanları iki kere kopyaladığını farkettim, bunun sebebi ne olabilir ?

Örnek dosya ektedir, mail at butonuna tıklayarak sonucu gözlemleyebilirsiniz.

Sub kod()
    Dim S1 As Worksheet: Set S1 = Sheets("mail için")
    Dim OutApp As Object
    Dim OutMail As Object
    sayfalar = Array("", "Araç")
    Dim i As Byte
    Dim sonsat As Integer
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    S1.Visible = True: S1.Select
    S1.Cells.Clear
    
    S1.Range("B1") = "Aşağıda detayları verilen araçların alınmasını rica ederim."
    S1.Range("B2") = " "
    
    
    For i = 1 To 3
        With Sheets(sayfalar(i))
            On Error Resume Next
            
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
            
            .Range("A1").AutoFilter Field:=1, Criteria1:="Bankada"
            .AutoFilter.Range.Copy
            sonsat = S1.Cells(Rows.Count, "B").End(3).Row + 1
            S1.Cells(sonsat, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            S1.Paste
            Application.CutCopyMode = False
            
            If sonsat <> 3 Then
                S1.Rows(sonsat).Delete Shift:=xlUp
            End If
        End With
    Next i
    
    For i = 1 To 3
        With Sheets(sayfalar(i))
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
        End With
    Next i
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
      
    sonsat = S1.Cells(Rows.Count, "B").End(3).Row + 1
    
    S1.Range("B1:I" & sonsat + 3).Copy
    With OutMail
        .To = "xx@xx.com.tr"
        .Subject = "Araç Alımları Hk."
        .Display
        DoEvents
        SendKeys "^v", True
    End With
    
    S1.Visible = False
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Application.SendKeys ("{NUMLOCK}")
    
End Sub

 

[askm]

Örnek dosyanızı eklerseniz daha hızlı sonuç alırsınız. Kodlara göre sayfalar oluşturup veri ile doldurmakla gerekecek yoksa.

 

[tirEdsOuL]

Örnek dosya ilk mesaja yüklenmiştir.

 

[askm]

Örnek dosyanızı gerek f8 ile gerekse f5 ile çalıştırdığımda bilgilerin Araç sayfasından 775 ve 779. satırlardaki veriler getiriliyor. Zaten kodlarınızda filtreleme kriteri olarak "bankada" yazanları listelemesini istemişsiniz. Yani benim çalıştırdığımda sıkıntı gözükmüyor.

 

[tirEdsOuL]

Çok enteresan, buraya yüklediğim dosya üzerinde şuanda tekrar denedim. 2 satır gelmesi gerekirken, 4 satır olarak geldi. Bilgisayardan kaynaklı nasıl bir problem olabilir ki ?

 

[tahsinanarat]

Bende indirip test ettim bankada seçilip filtreleme yapıldığında iki satır veri geliyor, bilginize.

 

[askm]

Açmış olduğunuzu sayfaları ve kodları yeni bir çalışma kitabına kopyalayıp farklı kaydedip deneyin.

 

[tirEdsOuL]

sorunu çözdüm sanırım, buraya yüklediğim dosyanın orjinalinde mail at butonun solunda yani J hücresine denk gelen alanda başka bir butunum vardı, kopyalama yaparken onuda alıyordu. Butonları biraz sağa doğru çektiğimde problem düzeldi.. Çok enterans..

İlginiz için teşekkürler..