Hi,
Can you please help me to solve this problem
Hi,
Can you please help me to solve this problem
I am also having the same doubt. How to rectify thisproblem
i copied this excel file to another system and check the program running step by step. It is running till the bellow line
Sub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String
Dim sht As Worksheet
Dim rng As Range
Dim sh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
Set sht = Sheets("Master data")
Set sh = Sheets("Data")
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If
'Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
On Error GoTo err_exit
With sht
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll
Display More
and after that this program jumping directly to
err_exit:
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
'Sheets("Master data").Range("A1").Select
End Sub
I am not understanding why it is happening another system only.
But in my system it is working properly.
Dear Team,
I created code for sending reminder mail from excel through outlook. My code is
Sub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String
Dim sht As Worksheet
Dim rng As Range
Dim sh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
Set sht = Sheets("Master data")
Set sh = Sheets("Data")
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If
'Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
On Error GoTo err_exit
With sht
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll
For i = 4 To lRow
If Cells(i, 5).Value <= 100 Or _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 Or _
.Cells(i, 20).Value >= 5 And .Cells(i, 20).Value <= 50 Or _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Or _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
Set OutMail = OutApp.CreateItem(0)
toList = .Cells(i, 24)
'CCList = Worksheets("Data").Cells(7, 3) & "; " & Worksheets("Data").Cells(8, 3) _
& "; " & Worksheets("Data").Cells(9, 3) & "; " & Worksheets("Data").Cells(10, 3) _
& "; " & Worksheets("Data").Cells(11, 3)
If .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine / Transmission / Axle & Hydraulic] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine / Transmission & Axle] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine / Transmission & Hydraulic] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine & Axle] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine & Transmission] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission / Axle & Hydraulic] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission & Axle] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission & Hydraulic] Service"
ElseIf .Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Axle & Hydraulic] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission] Service"
ElseIf .Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Axle] Service"
ElseIf .Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Hydraulic] Service"
End If
eBody = "<p style='font-family:Cambria;font-size: 12pt'>" & "Dear Sir, <br><br>" _
& "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _
& " We hope you're doing well.<br><br>" _
& " We wanted to inform you that your " & "<b>" & Cells(i, "C").Value & "</b>" _
& " Machine (Sr.No: " & "<b>" & Cells(i, "D") & "</b>" _
& ") reached " & "<b>" & .Cells(i, "T").Value & "</b>" & "hrs and due for next oil service.<br><br>" _
& " So kindly arrange the consumables as per the attachment.<br><br>" _
& " We truly care about your well-being, so if you have any questions or needs in advance of your appointment, you are welcome to call us anytime," & RangetoHTML(rng) & "<br><br>" & S & "</p>"
'Print '************************************************* ********
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to a temporary file
Dim wks As Worksheet
mySheet = Worksheets("Master data").Cells(i, "C").Value
TempFilePath = Environ$("temp") & "\"
'TempFileName = mySheet & "Service details.pdf"
If .Cells(i, 5).Value <= 100 Then
TempFileName = mySheet & " Engine Service Spares.pdf"
End If
FileFullPath = TempFilePath & TempFileName
Set MR = Cells(i, "C")
If .Cells(i, 5).Value <= 100 Then
'mr.Interior.Color = VBA.ColorConstants.vbGreen
Worksheets(mySheet).Range("B2:F46").ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
On Error Resume Next
With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.HTMLBody = eBody
.display
.Attachments.Add FileFullPath
'.Send
End With
On Error GoTo 0
End If
Next i
End With
Set OutApp = Nothing
ActiveWorkbook.Save
err_exit:
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
'Sheets("Master data").Range("A1").Select
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Display More
This code is working perfectly and mails are triggering on my laptop. But when i am using my file to another laptop this code is not working.
Can any one please help me where is the mistake on this code
Can any one help me how to do above my requirement
Dear Team,
I had created code for sending reminder mail. I want use my mail body as bellow format
Dear
Sir,
Greetings from SCHWING STETTER!
We hope you're doing well.
We wanted to inform you that your LW300FN(ARAI) Machine (Sr.No: sdfasd)
reached 480hrs and due for next oil service.
Description | Last Service | Remaining Hours |
Engine | 250 | 20 |
Master data "E3" (Cell) | Master data "L5" (Cell) | Master data "E5" (Cell) |
So kindly arrange the consumables as per the attachment.
We truly care about your well-being, so if you have any questions or needs in
advance of your appointment, you are welcome to call us anytime,.
1st Escalation | 2nd Escalation |
Mr. Muralidhar/9741212029, Mr. Sagar/9148840402 Bengaluru motorcycle works Mail [email protected] | Mr. Muniraj.M/9606933747 Schwing stetter india pvt ltd, Mail [email protected] |
Data C1:D2
My code is
eBody = "<p style='font-family:Cambria;font-size: 12pt'>" & "Dear Sir, <br><br>" _
& "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _
& " We hope you're doing well.<br><br>" _
& " We wanted to inform you that your " & "<b>" & Cells(i, "C").Value & "</b>" _
& " Machine (Sr.No: " & "<b>" & Cells(i, "D") & "</b>" _
& ") reached " & "<b>" & .Cells(i, "T").Value & "</b>" & "hrs and due for next oil service.<br><br>" _
& " So kindly arrange the consumables as per the attachment.<br><br>" _
& " We truly care about your well-being, so if you have any questions or needs in advance of your appointment, you are welcome to call us anytime,.<br><br>" & S & "</p>"
I don't know how to add table format on this code. Can any one please help me how to do this.
I am attaching my file here for your reference.
Hi ,
I found that if the machine model is "LW300FV(ARAI)" then entire column changed to "=2000 - (T4-Q4)" other wise entire column goes to "=1000 - (T4-Q4)".
But when the machine model is "LW300FV(ARAI)" or "ZL50GV(ARAI)" the particular row only change to "=2000 - (T4-Q4)" other wise it should be in "=1000 - (T4-Q4)".
Hi ,
The problem is not "V" & "N". I had checked with both of this.
The problem is this calculating with first condition (what ever the value is entered) only and this is considering second condition ( else condition)
How to do this
My code will copy the data's from multiple workbook and paste that datas on my master workbook.
In column C Employee name and Column D Employee NO is available all the workbook and master work book also.
This code will copy and paste where the employee no is matching.
But i want paste the value where the Employee name and No both should match.
And If the Employee no is blank the value should not copy.
And If any value is blank on the filed in sub workbook, on my master workbook it should update 0.
I am attaching my Master and Sub files here for your reference. Can you please check and update it
Hi i cheeked your code. But it is not working. If the condition is same or different, but this is taking only the first condition.
can you please check and confirm
Dear Team,
i am using the bellow code for copy paste data's from multiple worksheet
Sub CopyData()
Application.ScreenUpdating = False
Dim SrcWkb As Workbook, SrcWks As Worksheet, DstWkb As Workbook, DstWks As Worksheet, Val As String
Dim i As Long, j, v1, v2, RngList As Object, strExtension As String
Dim sFolderName As String, sFolderPath As String
Dim m As Long
Set DstWks = ThisWorkbook.Sheets("Dest")
v1 = DstWks.Range("D3", DstWks.Range("D" & Rows.Count).End(xlUp)).Value
sFolderPath = "E:\KRA Summary\"
sFolderName = Format(Date, "yyyy") & "\" & Format(DateAdd("M", -1, Now), "mmmm") & "\"
strExtension = Dir(sFolderPath & sFolderName & "*.xlsx*")
Do While strExtension <> ""
Set SrcWkb = Workbooks.Open(sFolderPath & sFolderName & strExtension)
v2 = Sheets(1).Range("D3", Sheets(1).Range("D" & Rows.Count).End(xlUp)).Resize(, 14).Value
m = Month(WorksheetFunction.EDate(Date, -1))
Set RngList = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(v2, 1)
Val = v2(i, 1)
If Not RngList.Exists(Val) Then
RngList.Add Key:=Val, Item:=i
End If
Next i
For i = 1 To UBound(v1, 1)
Val = v1(i, 1)
If RngList.Exists(Val) Then
DstWks.Cells(i + 2, m + 4) = Sheets(1).Cells(RngList(Val) + 2, m + 4)
End If
Next i
SrcWkb.Close False
strExtension = Dir
Loop
Dim rowcont As Long, x As Long
rowcont = Cells(Rows.Count, 3).End(xlUp).row
For x = 3 To rowcont
If Range("A" & x) And Range("D" & x) <> "" Then
Range("Q" & x).Value = Application.WorksheetFunction.Average(Range("E" & x & ":" & "P" & x))
End If
Next x
For x = 3 To rowcont
If Range("A" & x) And Range("D" & x) <> "" Then
Range("R" & x) = Application.WorksheetFunction.Rank(Range("Q" & x), Range("Q" & 3 & ":" & "Q" & rowcont))
End If
Next x
Range("R3:R" & rowcont).NumberFormat = "@"
Application.ScreenUpdating = True
End Sub
Display More
I above code it will match the name on column D and paste the value accordingly.
v1 = DstWks.Range("D3", DstWks.Range("D" & Rows.Count).End(xlUp)).Value
v2 = Sheets(1).Range("D3", Sheets(1).Range("D" & Rows.Count).End(xlUp)).Resize(, 14).Value
But i want this code should match the name from Column C & D and paste the value.
How can i modify the code. Can any one pls help me
Is it possible to use the condition before execute the calculation
I had changed your code like this
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim LRow As Long
Set ws = ThisWorkbook.Sheets("Master Data")
With ws
LRow = .Range("T" & .Rows.Count).End(xlUp).Row
.Range("E4:E" & LRow).Formula = "=250 - (T4-L4)"
.Range("F4:F" & LRow).Formula = "=600 - (T4-M4)"
.Range("G4:G" & LRow).Formula = "=1000 - (T4-N4)"
.Range("H4:H" & LRow).Formula = "=1000 - (T4-O4)"
.Range("I4:I" & LRow).Formula = "=1000 - (T4-P4)"
.Range("K4:K" & LRow).Formula = "=2000 - (T4-R4)"
.Range("J4:J" & LRow).Formula = "=1000 - (T4-Q4)"
End With
End Sub
Display More
But i want use condition for J4:J
If .Range("C4:C" & LRow).Value = "ZL50GV(ARAI)" Or .Range("C4:C" & LRow).Value = "LW300FV(ARAI)" Then
.Range("J4:J" & LRow).Formula = "=2000 - (T4-Q4)"
Else
.Range("J4:J" & LRow).Formula = "=1000 - (T4-Q4)"
End If
With this above code i am getting "Type mismatch error".
I am attaching my file here for your reference. Can you please check and confirm
Thanks for your support.
The code is working great.
If anything is required i will reply back.
Because now there is no values updated on L & T. But in E it is updating 250 for all the rows.
yes correct
Hi ,
Your code is working. But where the row is in blank on T column then this formula should not update. Once the value is entered on T column then only this formula to be update the value on E. Can you pls change it
Dear Team,
I am writing code for calculating my values. My code is
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheets("Master data").Range("E4").Value = (250 - (Sheets("Master data").Range("T4").Value - Sheets("Master data").Range("L4").Value))
End Sub
This calculation to be continued for all the rows bellow from E4.
For example
E4= 250-(T4-L4)
E5= 250-(T5-L5)
E6 = 250-(T5-L5)
Like that this formula to be applied automatically for all the rows .
can any one help me to how to do this
Dear Sobi,
Sorry for late reply.
On your file the code is working properly without any error.
But when i use the same code on my excel i am getting the same error message.
I am attaching my file here for your reference. Please check and clear the error