Posts by elsuji

elsuji · Sep 2nd 2020

Hi,

Can you please help me to solve this problem

elsuji · Sep 2nd 2020

I am also having the same doubt. How to rectify thisproblem

elsuji · Sep 2nd 2020

i copied this excel file to another system and check the program running step by step. It is running till the bellow line

Code

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

Code

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.

elsuji · Sep 2nd 2020

Dear Team,

I created code for sending reminder mail from excel through outlook. My code is

Code

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

elsuji · Sep 1st 2020

Can any one help me how to do above my requirement

elsuji · Aug 30th 2020

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

Code

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.

elsuji · Aug 30th 2020

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)".

elsuji · Aug 30th 2020

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)

elsuji · Aug 29th 2020

How to do this

elsuji · Aug 29th 2020

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

elsuji · Aug 29th 2020

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

elsuji · Aug 29th 2020

Dear Team,

i am using the bellow code for copy paste data's from multiple worksheet

Code

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.

Code

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

elsuji · Aug 28th 2020

Is it possible to use the condition before execute the calculation

I had changed your code like this

Code

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

Code

 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

elsuji · Aug 28th 2020

Thanks for your support.

The code is working great.

If anything is required i will reply back.

elsuji · Aug 28th 2020

Because now there is no values updated on L & T. But in E it is updating 250 for all the rows.

elsuji · Aug 28th 2020

yes correct

elsuji · Aug 28th 2020

yes

elsuji · Aug 28th 2020

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

elsuji · Aug 27th 2020

Dear Team,

I am writing code for calculating my values. My code is

Code

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

elsuji · Aug 26th 2020

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

Posts by elsuji

calculation for all the rows

Code is not working on other system

Code is not working on other system

Code is not working on other system

Table format in Outlook body

Table format in Outlook body

calculation for all the rows

calculation for all the rows

Define two columns on End(xlUp)).Value

Define two columns on End(xlUp)).Value

calculation for all the rows

Define two columns on End(xlUp)).Value

calculation for all the rows

calculation for all the rows

calculation for all the rows

calculation for all the rows

calculation for all the rows

calculation for all the rows

calculation for all the rows

VBA code for calculating Average and No.of Position