Why doesn't working? Application-defined or object-defined error

[SupperDuck]

Dear all,

I have a macro code that does;

Step 1: Making sheets looking on codes in column D (same codes in one sheet
that has the value in that group)

Step 2: Saving that sheets to new workbooks.

Step3: Sending e-mail to given addresses.

When i run the macro, there is no problem in step 1 and 2. But i got error
in row that has the code. ".Send"

But when i cut the Step 3, paste it to a new macro, there is no error.

I don't why it is happening

Can you please help me?

You can see the code below;


Kindest regards,





Sub mcr()
Dim FolderName As String

Dim DateString As String

Dim FolderAddress As String


DateString = Format(Now, "dd-mm")

Set WbMain = ThisWorkbook

FolderName = WbMain.Path & "\" & DateString

MkDir FolderName

With Selection.QueryTable
.RefreshOnFileOpen = False

End With

Range("A1:N10000").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Columns("A:B").Select
Selection.Delete Shift:=xlToLeft


ActiveWorkbook.SaveAs Filename:= _
WbMain.Path & "\" & DateString & "\" & DateString & ".xls",
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False

With Selection.QueryTable
.Name = "BakiyeListesi2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With

Cells.Select

Selection.WrapText = True

Columns("a:l").Select

With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Range("A1:L1").Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
.AddIndent = False

End With

Dim ilk_degisken As String

Dim sonraki_degisken As String

Dim kontrol, ilk_satir, son_satir, baslangic, bitis, ilk_ad

Dim sira_sut, sira_sut2, sheet_sayisi, yeni_sheet

sira_sut = "B"

'istenilen sutunu basa alir

If sira_sut <> "a" And sira_sut <> "A" Then

sira_sut2 = sira_sut & ":" & sira_sut

Columns(sira_sut2).Select

On Error GoTo 0

Selection.Cut

Columns("A:A").Select

Selection.Insert Shift:=xlToRight

Range("B6").Select

End If

ilk_ad = ActiveSheet.Name

Sheets(ilk_ad).Name = "ana_sayfa"

'Ana worksheet A1 göre sıralar

Range("A1").Select

'Selection.CurrentRegion.Select

'Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _

'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

ilk_degisken = Cells(2, 1).Value

Range("A2").Select

sheet_sayisi = 0

ilk_satir = 2

son_satir = 3

Selection.CurrentRegion.Select

i = Selection.Rows.Count

'Ä°slem burada basliyor

For j = 3 To i + 1

sonraki_degisken = Cells(j, 1).Value

If sonraki_degisken <> ilk_degisken Then

son_satir = j - 1

baslangic = "A" & ilk_satir

bitis = "gg" & son_satir

adres = baslangic & ":" & bitis

'MsgBox baslangic

'MsgBox bitis

Range(adres).Select

Application.CutCopyMode = False

Selection.Copy

Sheets.Add

sheet_sayisi = sheet_sayisi + 1

Range("A2").Select

ActiveSheet.Paste

'active sheeti duzenler

sheet_name = ActiveSheet.Name

Sheets(sheet_name).Name = Cells(2, 1).Value

yeni_sheet = ActiveSheet.Name

Sheets("ana_sayfa").Select

Rows("1:1").Select

Selection.Copy

Sheets(yeni_sheet).Select

Range("A1").Select

ActiveSheet.Paste

Range("B6").Select

Cells.Select

Selection.RowHeight = 12.75

Rows("1").Select

Selection.RowHeight = 82


Columns("A:IV").Select

Columns("A:IV").EntireColumn.ColumnWidth = 25

Cells.Select

Cells.EntireRow.AutoFit

Cells.EntireColumn.AutoFit

Rows("1").Select

Rows("1").EntireRow.AutoFit

Range("A1").Select

Sheets("ana_sayfa").Select

ilk_degisken = Cells(j, 1).Value

ilk_satir = j

Range("A1").Select

End If

SendKeys "{ESC}"

Next



Dim Wb As Workbook
Dim sh As Worksheet


Dim isim As String
Dim TumIsim As String

Application.ScreenUpdating = False
Application.EnableEvents = False

Set WbMain = ThisWorkbook
FolderName = WbMain.Path

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy
Set Wb = ActiveWorkbook
TumIsim = Cells(2, 3).Value

isim = Left(TumIsim, 7)



' Make values from the formulas

' With Wb.Sheets(1).UsedRange
' .Value = .Value
' End With


'Wb.SaveAs WbMain.Path & "\" & Wb.Sheets(1).Name & " " & isim &
" .xls"
Wb.SaveAs WbMain.Path & "\" & Wb.Sheets(1).Name & ".xls"
Wb.Close False
End If

Next sh


'Sending the Email
Dim olApp As Outlook.Application

Dim olMail As MailItem

Dim CurrFile As String
Dim folderadres As String
Dim yazi As String


folderadres = "file:///F:\YedekParca\IKMAL\Yerli\" & DateString

yazi = "Merhaba"
yazi = yazi & vbNewLine
yazi = yazi & vbNewLine
yazi = yazi & DateString & " Tarihli firma bakiyelerine ulaşmak için
aşağıdaki linke tıklayabilirsiniz."
yazi = yazi & vbNewLine
yazi = yazi & vbNewLine
yazi = yazi & folderadres
yazi = yazi & vbNewLine
yazi = yazi & vbNewLine
yazi = yazi & "İyi çalışmalar"


Set olApp = New Outlook.Application

Set olMail = olApp.CreateItem(olMailItem)

With olMail

.To = "(e-mail address removed)"

.CC = "veysel_ozan@yaho"


.Subject = DateString & " tarihli firma bakiyeleri"

.Body = yazi

.Send

End With

Set olMail = Nothing

Set olApp = Nothing

MsgBox "Bitti"

ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

[SupperDuck]

What I found is,

When i use "display" instead of "send"

No errors...

But i dont want to pres send button