Skip to main content

AccessTr.neT


Excel Kitaplar Arası Geçişte Problem

Excel Kitaplar Arası Geçişte Problem

#7
bu arada kodlar da kopyalanıyor sayfayla beraber yeni kitap-->yeni sayfa-->sadece 3-4 satırı kopyala yapsak daha hızlı ve kolay olmaz mı? diğerlerinin arka planda çalışan kodlara ihtiyacı var mı? 
not: önerim sadece teorik nasıl yapılır bilmiyorum )

dilerim işinize yarar[Resim: do.php?imgf=4e2b9576b5131.jpg]
Sub MailActiveSheet()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim i As Integer

i = ActiveCell.Row '<=========== Eklenen Satır i ile aktif satır belirlenip ona göre kopyalama yapılır
With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With

Set Sourcewb = ThisWorkbook

ActiveSheet.Copy
Set Destwb = ActiveWorkbook

With Destwb
   FileExtStr = ".xlsb": FileFormatNum = 50
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = " " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

'================>Eklenen<==========================================
Range(i & ":" & i).Copy Destwb.Worksheets("W.O KAYIT").Range("4:4")   '<=========== Eklenen Satır sadece seçtiğiniz satırı kopyalar
Destwb.Worksheets("W.O KAYIT").Range("A5:Z993").Clear                 '<=========== Eklenen Satır Geriye kalanı siler
'================>Eklenen BİTTİ<==========================================

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
   .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
   On Error Resume Next
   With OutMail
       .to = ""
       .CC = ""
       .BCC = ""
       .Subject = "C&I BAKIM WORK ORDER"
       .Body = "Sayın İlgililer" & vbNewLine & vbNewLine & "IT ile ilgili yeni oluşturulan iş emrini ekte görebilirsiniz." & vbNewLine & vbNewLine & "İyi Çalışmalar"
       .Attachments.Add Destwb.FullName
       '.Send
       .Display
   End With
   On Error GoTo 0
   .Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With
End Sub
.rar SatırKopyala_Hy.rar (Dosya Boyutu: 1,06 MB | İndirme Sayısı: 4)
Cevapla
#8
(10/05/2019, 04:21)haliliyas yazdı: bu arada kodlar da kopyalanıyor sayfayla beraber yeni kitap-->yeni sayfa-->sadece 3-4 satırı kopyala yapsak daha hızlı ve kolay olmaz mı? diğerlerinin arka planda çalışan kodlara ihtiyacı var mı? 
not: önerim sadece teorik nasıl yapılır bilmiyorum )

dilerim işinize yarar[Resim: do.php?imgf=4e2b9576b5131.jpg]
Sub MailActiveSheet()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim i As Integer

i = ActiveCell.Row '<=========== Eklenen Satır i ile aktif satır belirlenip ona göre kopyalama yapılır
With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With

Set Sourcewb = ThisWorkbook

ActiveSheet.Copy
Set Destwb = ActiveWorkbook

With Destwb
   FileExtStr = ".xlsb": FileFormatNum = 50
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = " " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

'================>Eklenen<==========================================
Range(i & ":" & i).Copy Destwb.Worksheets("W.O KAYIT").Range("4:4")   '<=========== Eklenen Satır sadece seçtiğiniz satırı kopyalar
Destwb.Worksheets("W.O KAYIT").Range("A5:Z993").Clear                 '<=========== Eklenen Satır Geriye kalanı siler
'================>Eklenen BİTTİ<==========================================

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
   .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
   On Error Resume Next
   With OutMail
       .to = ""
       .CC = ""
       .BCC = ""
       .Subject = "C&I BAKIM WORK ORDER"
       .Body = "Sayın İlgililer" & vbNewLine & vbNewLine & "IT ile ilgili yeni oluşturulan iş emrini ekte görebilirsiniz." & vbNewLine & vbNewLine & "İyi Çalışmalar"
       .Attachments.Add Destwb.FullName
       '.Send
       .Display
   End With
   On Error GoTo 0
   .Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With
End Sub
Son Düzenleme: 10/05/2019, 16:59, Düzenleyen: ertus35.
Cevapla
#9
Hocam emeğinize sağlık , çok güzel hazırlamışsınız,uğraşmışsınız. Fakat mailde ek olmasına gerek yok. Yapmak istediğim Sadece örnek: A4 ile L4 arasınındaki iş emrini mail body'sine yazmasıdır. Örneği eklşyorum.

Saygılarımla

[img][Resim: do.php?imgf=91c9afda51001.png][/img]
Son Düzenleme: 10/05/2019, 17:05, Düzenleyen: ertus35. (Sebep: Ek)
Cevapla
#10
resim geldi mi acaba. Yükleyemedim sanırım resmi.
Son Düzenleme: 10/05/2019, 17:00, Düzenleyen: ertus35.
Cevapla
#11
dilerim işinize yarar)
.rar MailBodyEkle_hy.rar (Dosya Boyutu: 1,07 MB | İndirme Sayısı: 6)
Cevapla
#12
(10/05/2019, 16:54)ertus35 yazdı: resim geldi mi acaba. Yükleyemedim sanırım resmi.

(10/05/2019, 18:22)haliliyas yazdı: dilerim işinize yarar)

Halil Bey,

Tabiki işime çok yarıyor. Çok sağ olun. Önce Sizin oluşturduğunuzu atacağım. Sonra benim son olarak sizden ricamı atacağım. 

Tüm satırı aldığında tablo çevreleri ve gizli sütunlardan dolayı mail yana doğru çok uzuyor  . Biz Sadece K ve L sütunlarını alabilir miyiz ve bu yazı "IT ile ilgili yeni oluşturulan iş emrini ekte görebilirsiniz. İyi Çalışmalar" yazısının altına gelbilir mi.

Saygılarımla[img][Resim: do.php?imgf=6636d441b1f41.png][/img]
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da