Kod:
Private Sub CBFILTREAKTAR_Click()
On Error Resume Next
Dim File_Name As String, My_Folder As Variant, X As Long
Dim My_Sheet As Worksheet, My_Check As Boolean, My_Count As Byte
Dim My_Box As Object, My_Area As Range, Last_Row As Long
10 If My_Count = 3 Then
MsgBox "Çok Fazla Deneme Yaptınız!" & vbCrLf & vbCrLf & _
"Lütfen Daha Sonra Tekrar Deneyiniz.", vbExclamation, "Veri Aktarma Hatası"
Exit Sub
End If
File_Name = InputBox("Lütfen Aktarmak İstediğiniz Dosyanın Adını Giriniz.", "DOSYA ADI")
If File_Name = "" Then
MsgBox "Filtrelediğiniz Verinlerin Aktarılması İçin Dosya Adı Belirlemelisiniz!", vbCritical, "Veri Aktarma Hatası"
Exit Sub
End If
If My_Check = False Then
Set My_Folder = CreateObject("Shell.Application").BrowseForFolder(0, _
"Lütfen Aktarımını Yapmak İstediğiniz Dosyanın Kaydedileceği Klasörü Seçiniz.", &H100)
End If
If Not My_Folder Is Nothing Then
If Dir(My_Folder.Self.Path & "\" & File_Name & ".xlsx") <> "" Then
My_Count = My_Count + 1
If My_Count < 3 Then
MsgBox "Verileri Aktarmak İstediğiniz Klasörde Aynı İsimle Başka Bir Dosya Bulunuyor!" & vbCrLf & vbCrLf & _
" Lütfen Farklı Bir Dosya Adı Giriniz!", vbCritical
My_Check = True
GoTo 10
ElseIf My_Count = 3 Then
GoTo 10
End If
End If
Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "FİLTRELEME"
Set My_Sheet = Sheets("FİLTRELEME")
With My_Sheet
.Cells.ClearContents
Last_Row = .Cells(.Rows.Count, 1).End(3).Row + 1
.Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount) = FILTRELEME.ListBox1.List
.Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount).Borders.LineStyle = 1
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1000
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.text = ""
.EvenPage.CenterHeader.text = ""
.EvenPage.RightHeader.text = ""
.EvenPage.LeftFooter.text = ""
.EvenPage.CenterFooter.text = ""
.EvenPage.RightFooter.text = ""
.FirstPage.LeftHeader.text = ""
.FirstPage.CenterHeader.text = ""
.FirstPage.RightHeader.text = ""
.FirstPage.LeftFooter.text = ""
.FirstPage.CenterFooter.text = ""
.FirstPage.RightFooter.text = ""
End With
Application.PrintCommunication = True
.Range("A1:Q1").MergeCells = True
.Cells.Font.Name = "Times New Roman"
.Cells.Font.Size = 12
.Range("A1:Q1").Cells.Font.Size = 18
.Cells.VerticalAlignment = xlCenter
.Cells.HorizontalAlignment = xlCenter
.Cells.WrapText = True
.Range("A1:A2").EntireRow.Font.Bold = True
.Range("A:B").ColumnWidth = 50
.Range("C:E").ColumnWidth = 22
.Range("F:H").ColumnWidth = 12
.Range("I:I").ColumnWidth = 15
.Range("J:K").ColumnWidth = 100
.Range("L:L").ColumnWidth = 60
.Range("M:M").ColumnWidth = 13
.Range("N:O").ColumnWidth = 80
.Range("P:P").ColumnWidth = 25
.Range("Q:Q").ColumnWidth = 13
.Columns.AutoFit
.Rows.AutoFit
For Each My_Box In Me.Controls
If TypeName(My_Box) = "CheckBox" Then
If My_Box.Value = False And My_Box.Caption <> "TÜMÜNÜ SEÇ" Then
If My_Area Is Nothing Then
Set My_Area = .Cells(1, Val(Replace(My_Box.Name, "CheckBox", "")))
Else
Set My_Area = Union(My_Area, .Cells(1, Val(Replace(My_Box.Name, "CheckBox", ""))))
End If
End If
End If
Next
If Not My_Area Is Nothing Then My_Area.EntireColumn.Delete
.Range("A1").Value = "GENEL ARIZALAR"
End With
Application.ScreenUpdating = False
My_Sheet.Copy
ActiveWorkbook.SaveAs My_Folder.Self.Path & "\" & File_Name & ".xlsx", xlOpenXMLWorkbook, Local:=True
ActiveWorkbook.Close False
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("AGBF").Activate
Application.Visible = False
MsgBox "Filtrelediğiniz Veriler " & My_Folder.Self.Path & " Klasörüne " & File_Name & " İsmiyle Kaydedilmiştir.", vbInformation, "Veri Aktarma"
Set My_Area = Nothing
Set My_Sheet = Nothing
Set My_Folder = Nothing
Else
MsgBox "Klasör Seçimi Yapmadığınız İçin Veri Aktarım İşlemi Gerçekleştirilemedi.", vbCritical, "Veri Aktarma Hatası"
End If
End Sub
Private Sub CheckBoxEPOSTAGONDER_Click()
If CheckBoxEPOSTAGONDER = True Then
On Error Resume Next
Dim File_Name As String, My_Folder As Variant, X As Long
Dim My_Sheet As Worksheet, My_Check As Boolean, My_Count As Byte
Dim My_Box As Object, My_Area As Range, Last_Row As Long
Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "FİLTRELEME"
Set My_Sheet = Sheets("FİLTRELEME")
With My_Sheet
.Cells.ClearContents
Last_Row = .Cells(.Rows.Count, 1).End(3).Row + 1
.Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount) = FILTRELEME.ListBox1.List
.Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount).Borders.LineStyle = 1
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1000
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.text = ""
.EvenPage.CenterHeader.text = ""
.EvenPage.RightHeader.text = ""
.EvenPage.LeftFooter.text = ""
.EvenPage.CenterFooter.text = ""
.EvenPage.RightFooter.text = ""
.FirstPage.LeftHeader.text = ""
.FirstPage.CenterHeader.text = ""
.FirstPage.RightHeader.text = ""
.FirstPage.LeftFooter.text = ""
.FirstPage.CenterFooter.text = ""
.FirstPage.RightFooter.text = ""
End With
Application.PrintCommunication = True
.Range("A1:Q1").MergeCells = True
.Cells.Font.Name = "Times New Roman"
.Cells.Font.Size = 12
.Range("A1:Q1").Cells.Font.Size = 18
.Cells.VerticalAlignment = xlCenter
.Cells.HorizontalAlignment = xlCenter
.Cells.WrapText = True
.Range("A1:A2").EntireRow.Font.Bold = True
.Range("A:B").ColumnWidth = 50
.Range("C:E").ColumnWidth = 22
.Range("F:H").ColumnWidth = 12
.Range("I:I").ColumnWidth = 15
.Range("J:K").ColumnWidth = 100
.Range("L:L").ColumnWidth = 60
.Range("M:M").ColumnWidth = 13
.Range("N:O").ColumnWidth = 80
.Range("P:P").ColumnWidth = 25
.Range("Q:Q").ColumnWidth = 13
.Columns.AutoFit
.Rows.AutoFit
For Each My_Box In Me.Controls
If TypeName(My_Box) = "CheckBox" Then
If My_Box.Value = False And My_Box.Caption <> "TÜMÜNÜ SEÇ" Then
If My_Area Is Nothing Then
Set My_Area = .Cells(1, Val(Replace(My_Box.Name, "CheckBox", "")))
Else
Set My_Area = Union(My_Area, .Cells(1, Val(Replace(My_Box.Name, "CheckBox", ""))))
End If
End If
End If
Next
If Not My_Area Is Nothing Then My_Area.EntireColumn.Delete
.Range("A1").Value = "GENEL ARIZALAR"
End With
Dim OutApp As Object
Dim NewMail As Object
Dim ShName As String, WbName As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Sheets(ActiveSheet.Name).Copy
ShName = ActiveSheet.Name
WbName = ThisWorkbook.Path & "\" & ShName & ".xls"
ActiveWorkbook.SaveAs WbName, FileFormat:=-4143
ActiveWorkbook.Close False
Set OutApp = CreateObject("Outlook.Application")
Set NewMail = OutApp.CreateItem(0)
With NewMail
.Display
.Subject = "FİLTRELENEN VERİLER"
.Body = "Filtrelenen veriler Ektedir."
.Attachments.Add WbName
End With
Set NewMail = Nothing
Set OutApp = Nothing
Kill WbName
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("AGBF").Activate
Application.Visible = False
Else
Exit Sub
End If
End SubYukarıda iki adet kod bloğum var. Birincisi Filtrelediğim verileri bilgisayara kaydetmemi, diğeri ise mail olarak göndermemi sağlıyor.
Fakat ikisi de bu işlemleri yaptığı esnada farklı kaydet bölümünde arka planda gizli olan exceli anlık olarak açıp kapatıyor hatta mail kod bloğum anlıktan ziyade 3-4 saniye açık kalıp kayboluyor taki outlook ekranı görünene kadar. Benim arka planda açılıp kapanan excel ekranının hiçbir şekilde açmamasını sağlamamın bir yolu varmıdır acaba? Yardımcı olabilirseniz çok sevinirim. İyi günler dilerim.