Posts by elsuji

elsuji · Friday, 7:39 pm

Dear Dave,

The bellow is my code

Code

'For copy data to calibration reminder sheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim srcWB As Workbook, dstWB As Workbook, SrcWS As Worksheet, dstWS As Worksheet
Set srcWB = ThisWorkbook
Set SrcWS = srcWB.Worksheets("Data")
If Not Dir("C:\Users\" & Environ("username") & "\Desktop\Calibration - Reminder Mail.xlsm", vbDirectory) = vbNullString Then
On Error Resume Next
Set dstWB = Workbooks.Open("C:\Users\" & Environ("username") & "\Desktop\Calibration - Reminder Mail.xlsm")
Set dstWS = dstWB.Worksheets("Calibration")
If SrcWS.Range("AK5") = "" Then
With dstWS
Dim c11 As Range
Dim rnge As Range
Set rnge = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
For Each c11 In rnge.Cells
If UCase(c11) = UCase(SrcWS.Range("C5").Value) Then
If UCase(c11.Offset(, 3)) = UCase(SrcWS.Range("C11")) Then
If c11.Offset(, 4) = SrcWS.Range("C12") Then
If c11.Offset(, 9) = "" Then
c11.Offset(, 9) = "Calibration done on " & Date
Exit For
End If
End If
End If
End If
' Exit For
Next
If .Cells.Range("A4") = "" Then
.Cells.Range("A4") = "1"
Else
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) = .Cells(.Rows.Count, "A").End(xlUp) + 1
End If
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = SrcWS.Range("C5")
.Cells(.Rows.Count, "E").End(xlUp).Offset(1) = SrcWS.Range("C11")
.Cells(.Rows.Count, "F").End(xlUp).Offset(1) = SrcWS.Range("C12")
SrcWS.Range("AK5") = "OK"
End With
End If
dstWB.Close True
End If
Application.EnableEvents = True
Application.ScreenUpdating = True

Display More

how can i modify the code as per above said conditions

elsuji · Friday, 7:21 pm

If Destination workbook is already open i am getting error

Is it possible to ignore this error and print the value on destination

elsuji · Friday, 6:49 pm

Dear Dave,

I done small modification on your code

Code

Set rng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
For Each c In rng.Cells
If UCase(c) = UCase(Me.Range("C5").Value) Then
If UCase(c.Offset(, 3)) = UCase(Me.Range("C11")) Then
If c.Offset(, 4) = Me.Range("C12") Then
If c.Offset(, 9) = "" Then
c.Offset(, 9) = "Calibration done on " & Date
Exit For
End If
End If
End If
End If
Next c

Display More

Code

If c.Offset(, 9) = "" Then

I have one doubt.

I printed the "Calibration done on " & Date on column K.

If the same data's repeated again on another row. Then that time how this code will work.

I want to print "Calibration done on " & Date again on newly entered row only.

elsuji · Friday, 6:21 pm

Dear Dave,

Thanks for your reply. This code is working as per my requirement

elsuji · Friday, 4:46 am

Dear Team,

Help me to solve my above query

elsuji · Thursday, 7:21 pm

Dear Team,

I am having two workbook. Source.xlsm and Destination.xlsx.

In both the work book I am having customer name, Plant model and plant S.No details.

Once i press's Write Value button from source workbook, I want it should write "Calibration done" on Destination workbook Sheet 2 column K where my customer name, Plant model and plant S.No matching. And this "Calibration Done "

For example, If customer name, Plant model and plant S.No is matching on row 13 and K13 is blank then K13 it should print "Calibration done"

Can any one help me for solve this

I am attaching my file here for your reference.

elsuji · Thursday, 7:05 pm

Dear jolivanes,

Due to some personal work not able to reply you. Sorry for late reply.

Yes, I hide the row asper your suggestion. Now it is ok

elsuji · Oct 10th 2020

Dear Team,

I am having a code for convert range to PDF when my condition is meet.

Code is

Code

If Cells(r, "C").Value = "LW300FV(ARAI)" And Cells(r, "S").Value >= 400 And Cells(r, "S").Value <= 500 Then
Worksheets(mySheet).Range("B939:F980").ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

This is working properly.

But i want to include the range of Worksheets(mySheet).Range("B2:F24") along with the above code.

I don't know how to do this.

Can any one help me to solve this issue

elsuji · Oct 8th 2020

Dear

I cleared the above said error.

Modified Code is

Code

Dim mySheet As Integer
Dim TempFilePath As String
Dim TempFileName As String
mySheet = sh.Cells(r, "C").Value
TempFilePath = Environ$("temp") & "\"
If Cells(r, "E").Value <= 100 Then
TempFileName = mySheet & " Machine Engine, Transmission, Axle & Hydraulic Oil Service Spares.pdf"
End If

But now the error is coming on bellow code

Code

'PDF Range And Format
Dim FileFullPath As String
FileFullPath = TempFilePath & TempFileName
If Cells(r, 5).Value <= 100 Then
Worksheets(mySheet).Range("B5:F30").ExportAsFixedFormat _
Type:=xlTypePDF, FileName:=FileFullPath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If

Pls suggest me

elsuji · Oct 8th 2020

Dear Danglor,

I modified the code as per your suggestion. Now Mail is created. New code is

Code

Option Explicit
Sub Remindermail(r As Integer, cl As Integer)
Dim lRow 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
'On Error GoTo err_exit
'With sht
'lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
If Cells(r, "E").Value <= 100 Then
Set OutMail = OutApp.CreateItem(0)
Else: Exit Sub
End If
toList = Cells(r, 26).Value
'For mail subject
If Cells(r, "E").Value <= 100 Then
eSubject = "Reminder for your " & Cells(r, 3) & " Machine Engine, Transmission, Axle & Hydraulic Oil Service"
End If
'
'
'For mail Body
eBody = "" & "Dear Sir, " _
& "Greetings from " & " SCHWING STETTER! " _
& " We hope you're doing well. " _
& " We wanted to inform you that your " & "" & Cells(r, "C").Value & "" _
& " Machine (Sr.No: " & "" & Cells(r, "D") & "" _
& ") reached " & "" & Cells(r, "S").Value & "" & "hrs and due for next oil service. " _
& " 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," & RangetoHTML(rng) & " " & ""
'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 = sh.Cells(r, "C").Value
TempFilePath = Environ$("temp") & "\"
If Cells(r, "E").Value <= 100 Then
TempFileName = mySheet & " Machine Engine, Transmission, Axle & Hydraulic Oil Service Spares.pdf"
End If
Dim shhd As Worksheet
For Each shhd In ThisWorkbook.Worksheets
If shhd.Name <> "Master data" Then
shhd.Visible = xlSheetVisible
End If
Next
'PDF Range and format
FileFullPath = TempFilePath & TempFileName
Set MR = Cells(r, "C")
If Cells(r, 5).Value <= 100 Then
Worksheets(mySheet).Range("B879:F934").ExportAsFixedFormat _
Type:=xlTypePDF, FileName:=FileFullPath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Dim shhd1 As Worksheet
For Each shhd1 In ThisWorkbook.Worksheets
If shhd1.Name <> "Master data" Then
shhd1.Visible = xlSheetVeryHidden
End If
Next
'On Error Resume Next
With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.HTMLBody = eBody
.Display
.Attachments.Add FileFullPath
'.Send
End With
Set OutApp = Nothing
ActiveWorkbook.Save
'err_exit:
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
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

But i am getting error for mail attachment.

Code

'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 = sh.Cells(r, "C").Value
TempFilePath = Environ$("temp") & "\"
If Cells(r, "E").Value <= 100 Then
TempFileName = mySheet & " Machine Engine, Transmission, Axle & Hydraulic Oil Service Spares.pdf"
End If

Code

mySheet = sh.Cells(r, "C").Value

Error is

Can you please suggest me for clear this error

elsuji · Oct 8th 2020

Dear Dongler,

Can you please modify the code for me please

elsuji · Oct 8th 2020

Dear Team,

I am writing code for send Reminder mail to the customer .

In sheet i am having customer, Machine and machine hours details.

I am entering the machine hours details on Sheet "Master data", from Column L to S and In Column E to K I am using formula to calculate the values.

Example,

For "E10" the formula is =250 - (S10-L10). Where ever I am changing the value either S10 or L10, the calculated value is update on E10.

If E10 value is less than 100, then I want to trigger mail only the customer who is in the row 10.

If suppose i am entering the details on row 6 and E6 value is less than 100, then I want to trigger mail only the customer who is in the row 6.

For that I wrote code. My code is

Code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Integer, cl As Integer
If Not Application.Intersect(Target, Me.Range("L4:S999999")) Is Nothing Then
r = Target.Row
cl = Target.Column
Call Remindermail(r, cl)
End If
End Sub

Code

Sub Remindermail(r As Integer, cl As Integer)
Dim lRow As Integer
Dim r 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")
'On Error GoTo err_exit
'With sht
'lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
If Cells(r, 5).Value <= 100 Then
Set OutMail = OutApp.CreateItem(0)
End If
toList = .Cells(r, 26)
'For mail subject
If .Cells(r, 5).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(r, 3) & " Machine Engine, Transmission, Axle & Hydraulic Oil Service"
End If
'For mail Body
eBody = "" & "Dear Sir, " _
& "Greetings from " & " SCHWING STETTER! " _
& " We hope you're doing well. " _
& " We wanted to inform you that your " & "" & Cells(r, "C").Value & "" _
& " Machine (Sr.No: " & "" & Cells(r, "D") & "" _
& ") reached " & "" & .Cells(r, "S").Value & "" & "hrs and due for next oil service. " _
& " 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," & RangetoHTML(rng) & " " & ""
'For PDF attachment Name
Application.ScreenUpdating = False
Dim wks As Worksheet
mySheet = Worksheets("Master data").Cells(r, "C").Value
TempFilePath = Environ$("temp") & "\"
If .Cells(r, 5).Value <= 100 Then
TempFileName = mySheet & " Machine Engine, Transmission, Axle & Hydraulic Oil Service Spares.pdf"
End If
'For sheet Visibility to copy the range
Set mySheets = Sheets(Array("Data", "Customer Data", "ZL50GN(ARAI)", "ZL50GN(NON-ARAI)", "ZL50GV(ARAI)", "LW300FV(ARAI)", "LW300FN(ARAI)", "LW300FN(NON_ARAI)", "LW180K(ARAI)", "LW180K(NON-ARAI)", "Display"))
ReDim SheetVisibility(1 To mySheets.Count)
idx = 1
For Each sht In mySheets
SheetVisibility(idx) = sht.Visible
sht.Visible = xlSheetVisible
idx = idx + 1
Next sht
'PDF Range and format
FileFullPath = TempFilePath & TempFileName
Set MR = Cells(r, "C")
If .Cells(r, 5).Value <= 100 Then
Worksheets(mySheet).Range("B879:F934").ExportAsFixedFormat _
Type:=xlTypePDF, FileName:=FileFullPath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
'Sheets Hiden
idx = 1
For Each sht In mySheets
sht.Visible = xlSheetVeryHidden
idx = idx + 1
Next sht
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 With
Set OutApp = Nothing
ActiveWorkbook.Save
err_exit:
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
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

But when i am checking by changing the value, the mail is not triggering.

Can any one please help me for solving this issue.

I attached my file here for your reference

elsuji · Oct 6th 2020

Dear Roy,

Thanks for your support

elsuji · Oct 6th 2020

Dear Roy,

There is no code on

Code

Private Sub ComboBox2_Change()
End Sub

elsuji · Oct 6th 2020

Dear Roy,

I really don't know. Please help me

elsuji · Oct 6th 2020

Dear Roy,

I modified the code with copy paste the datas to another sheet. Now the listbox header is updating

New code is

Code

Sub FindAll()
'For Filtering and Updating to Listbox1 by match the ComboBox2 Value from Sheet "Custmer Data"
Dim strFind As String, rFilter As Range
With Worksheets("Customer Data")
Set rFilter = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With Worksheets("Customer Data")
On Error Resume Next
If Not .AutoFilterMode Then .Range("B2").AutoFilter
On Error Resume Next
End With
strFind = Me.ComboBox2.Value
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Display")
Dim dsh As Worksheet
Set dsh = ThisWorkbook.Sheets("Customer Data")
rFilter.AutoFilter Field:=2, Criteria1:="=*" & strFind & "*", Operator:=xlFilterValues
Me.ComboBox2.Clear
sh.Cells.ClearContents
dsh.UsedRange.Copy
sh.Range("A1").PasteSpecial xlPasteValues
Dim Last_Row As Long
Last_Row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
Set rng = rng.Cells.SpecialCells(xlCellTypeVisible)
For Each c In rng
With Me.ListBox1
.ColumnHeads = True
.ColumnCount = 8
.ColumnWidths = "30,150,100,110,80,100,75,125"
If Last_Row = 1 Then
.RowSource = "Display!A2:H2"
Else
.RowSource = "Display!A2:H" & Last_Row
End If
End With
Next c
Me.ListBox1.ListIndex = 0
With Worksheets("Display")
.ShowAllData
.AutoFilterMode = False
End With
End Sub

Display More

Code

Private Sub ComboBox2_Change()
'For search the values which is entering on ComboBox2
Dim strFind As String, FirstAddress As String, rSearch As Range
Dim f As Integer, lngItem As Long
' ListBox1.Clear
With Worksheets("Customer Data")
Set rSearch = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With
strFind = Me.ComboBox2.Value
With rSearch
Set c = .Find(strFind)
If Not c Is Nothing Then
With Me
For lngItem = 1 To 8
' .Controls("ListBox1" & lngItem).Value = c.Offset(0, lngItem - 1).Value
Next
f = 0
End With
FirstAddress = c.Address
Do
f = f + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
If f > 0 Then
Call FindAll
End If
Else
' MsgBox "Not Found. You entered '" & strFind & "' - Please Enter a valid First Name."
End If
End With
With Worksheets("Customer Data")
If .AutoFilterMode Then
.AutoFilterMode = False
End If
End With
End Sub

Display More

But only one small problem. When my combobox2 is blank the list box should not display any only. Only it should display value if I type any vales on Combobox2.

My request is can you please check and correct the code Please

elsuji · Oct 6th 2020

Dear Roy,

Can you please help me how to do this.

elsuji · Oct 5th 2020

Dear Team,

I had created the userform for Add, Update, Delete the customer details. And I am having listbox for display the details. When i am entering any values on Combobox2. it will search the customer name accordingly and display the details on Listbox1.

I want to update the header for my listbox1. The header range is Sheet "Customer Data" ("A2:H2").

My code is

Code

Sub FindAll()
'For Filtering and Updating to Listbox1 by match the ComboBox2 Value from Sheet "Custmer Data"
Dim strFind As String, rFilter As Range
With Worksheets("Customer Data")
Set rFilter = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With Worksheets("Customer Data")
On Error Resume Next
If Not .AutoFilterMode Then .Range("B2").AutoFilter
On Error Resume Next
End With
strFind = Me.ComboBox2.Value
rFilter.AutoFilter Field:=2, Criteria1:="=*" & strFind & "*", Operator:=xlFilterValues
Set rng = rng.Cells.SpecialCells(xlCellTypeVisible)
Me.ComboBox2.Clear
For Each c In rng
With Me.ListBox1
.ColumnHeads = True
.ColumnCount = 8
.ColumnWidths = "30,150,100,110,80,100,75,125"
.AddItem c.Value
.List(.ListCount - 1, 1) = c.Offset(, 1)
.List(.ListCount - 1, 2) = c.Offset(, 2)
.List(.ListCount - 1, 3) = c.Offset(, 3)
.List(.ListCount - 1, 4) = c.Offset(, 4)
.List(.ListCount - 1, 5) = c.Offset(, 5)
.List(.ListCount - 1, 6) = c.Offset(, 6)
.List(.ListCount - 1, 7) = c.Offset(, 7)
.List(.ListCount - 1, 8) = c.Offset(, 8)
End With
Next c
Me.ListBox1.ListIndex = 0
With Worksheets("Customer Data")
.ShowAllData
.AutoFilterMode = False
End With
End Sub
Private Sub ComboBox2_Change()
'For search the values which is entering on ComboBox2
Dim strFind As String, FirstAddress As String, rSearch As Range
Dim f As Integer, lngItem As Long
ListBox1.Clear
With Worksheets("Customer Data")
Set rSearch = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With
strFind = Me.ComboBox2.Value
With rSearch
Set c = .Find(strFind)
If Not c Is Nothing Then
With Me
For lngItem = 1 To 8
' .Controls("ListBox1" & lngItem).Value = c.Offset(0, lngItem - 1).Value
Next
f = 0
End With
FirstAddress = c.Address
Do
f = f + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
If f > 0 Then
Call FindAll
End If
Else
' MsgBox "Not Found. You entered '" & strFind & "' - Please Enter a valid First Name."
End If
End With
With Worksheets("Customer Data")
If .AutoFilterMode Then
.AutoFilterMode = False
End If
End With
End Sub

Display More

I don't know how to add this headers.

I am attaching my file here for your reference.

Please help me to solve this issue

elsuji · Oct 1st 2020

Dear Roy,

I tried this code

Code

Last_Row = Application.WorksheetFunction.Match(ws.Range("D7").Value, sh.Range("B:B"), 0)

But i am getting following error message

Please help me

elsuji · Oct 1st 2020

Then After modified the required fiels on sheet "Inward_Edit" , fo rover write the values and print to pdf, i am using the bellow code.

Code

Sub Inward_Edit_Update()
Dim dsh As Worksheet
Set dsh = ThisWorkbook.Sheets("Inward_Print")
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Inward_View")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Inward_Edit")
Dim ows As Worksheet
Set ows = ThisWorkbook.Sheets("Data")
Dim Last_Row As Long
Last_Row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
'For update to Sheet "Inward View"
sh.Range("A" & Last_Row + 1).Value = "=IF(B" & Last_Row + 1 & "="""","""",ROW()-1)"
sh.Range("B" & Last_Row + 1).Value = ws.Range("D5")
sh.Range("C" & Last_Row + 1).Value = ws.Range("D7")
sh.Range("D" & Last_Row + 1).Value = ws.Range("D11")
sh.Range("E" & Last_Row + 1).Value = ws.Range("D13")
sh.Range("F" & Last_Row + 1).Value = ws.Range("D15")
sh.Range("G" & Last_Row + 1).Value = ws.Range("D17")
sh.Range("H" & Last_Row + 1).Value = ws.Range("D19")
sh.Range("I" & Last_Row + 1).Value = ws.Range("D21")
sh.Range("J" & Last_Row + 1).Value = ws.Range("D23")
sh.Range("K" & Last_Row + 1).Value = ws.Range("D25")
sh.Range("L" & Last_Row + 1).Value = ws.Range("D27")
sh.Range("M" & Last_Row + 1).Value = ws.Range("D29")
sh.Range("N" & Last_Row + 1).Value = ws.Range("D31")
sh.Range("O" & Last_Row + 1).Value = ws.Range("D33")
sh.Range("P" & Last_Row + 1).Value = ws.Range("D35")
sh.Range("Q" & Last_Row + 1).Value = ws.Range("D37")
sh.Range("R" & Last_Row + 1).Value = ws.Range("D39")
sh.Range("S" & Last_Row + 1).Value = ws.Range("D41")
sh.Range("T" & Last_Row + 1).Value = ws.Range("D43")
sh.Range("U" & Last_Row + 1).Value = ws.Range("D45")
sh.Range("V" & Last_Row + 1).Value = ws.Range("D47")
sh.Range("W" & Last_Row + 1).Value = ws.Range("D49")
sh.Range("X" & Last_Row + 1).Value = ws.Range("D51")
sh.Range("Y" & Last_Row + 1).Value = ws.Range("G11")
sh.Range("Z" & Last_Row + 1).Value = ws.Range("G13")
sh.Range("AA" & Last_Row + 1).Value = ws.Range("G15")
sh.Range("AB" & Last_Row + 1).Value = ws.Range("G17")
sh.Range("AC" & Last_Row + 1).Value = ws.Range("G19")
sh.Range("AD" & Last_Row + 1).Value = ws.Range("G21")
sh.Range("AE" & Last_Row + 1).Value = ws.Range("G23")
sh.Range("AF" & Last_Row + 1).Value = ws.Range("G25")
sh.Range("AG" & Last_Row + 1).Value = ws.Range("G27")
sh.Range("AH" & Last_Row + 1).Value = ws.Range("G29")
sh.Range("AI" & Last_Row + 1).Value = ws.Range("G33")
sh.Range("AJ" & Last_Row + 1).Value = ws.Range("G35")
sh.Range("AK" & Last_Row + 1).Value = ws.Range("G37")
sh.Range("AL" & Last_Row + 1).Value = ws.Range("G39")
sh.Range("AM" & Last_Row + 1).Value = ws.Range("G41")
sh.Range("AN" & Last_Row + 1).Value = ws.Range("G43")
sh.Range("AO" & Last_Row + 1).Value = ws.Range("G45")
sh.Range("AP" & Last_Row + 1).Value = ws.Range("C54")
sh.Range("AQ" & Last_Row + 1).Value = ws.Range("C57")
sh.Range("AR" & Last_Row + 1).Value = ws.Range("D60")
sh.Range("AS" & Last_Row + 1).Value = ws.Range("D62")
sh.Range("AT" & Last_Row + 1).Value = ws.Range("D64")
sh.Range("AU" & Last_Row + 1).Value = ws.Range("G60")
sh.Range("AV" & Last_Row + 1).Value = ws.Range("G62")
sh.Range("AW" & Last_Row + 1).Value = ws.Range("G64")
sh.Range("AX" & Last_Row + 1).Value = "=IF(B" & Last_Row + 1 & "="""","""",ROW()-1)"
'For Update to Sheet "Inward_Print"
dsh.Range("D5").Value = ws.Range("D5")
dsh.Range("D7").Value = ws.Range("D7")
dsh.Range("D11").Value = ws.Range("D11")
dsh.Range("D13").Value = ws.Range("D13")
dsh.Range("D15").Value = ws.Range("D15")
dsh.Range("D17").Value = ws.Range("D17")
dsh.Range("D19").Value = ws.Range("D19")
dsh.Range("D21").Value = ws.Range("D21")
dsh.Range("D23").Value = ws.Range("D23")
dsh.Range("D25").Value = ws.Range("D25")
dsh.Range("D27").Value = ws.Range("D27")
dsh.Range("D29").Value = ws.Range("D29")
dsh.Range("D31").Value = ws.Range("D31")
dsh.Range("D33").Value = ws.Range("D33")
dsh.Range("D35").Value = ws.Range("D35")
dsh.Range("D37").Value = ws.Range("D37")
dsh.Range("D39").Value = ws.Range("D39")
dsh.Range("D41").Value = ws.Range("D41")
dsh.Range("D43").Value = ws.Range("D43")
dsh.Range("D45").Value = ws.Range("D45")
dsh.Range("D47").Value = ws.Range("D47")
dsh.Range("D49").Value = ws.Range("D49")
dsh.Range("D51").Value = ws.Range("D51")
dsh.Range("G11").Value = ws.Range("G11")
dsh.Range("G13").Value = ws.Range("G13")
dsh.Range("G15").Value = ws.Range("G15")
dsh.Range("G17").Value = ws.Range("G17")
dsh.Range("G19").Value = ws.Range("G19")
dsh.Range("G21").Value = ws.Range("G21")
dsh.Range("G23").Value = ws.Range("G23")
dsh.Range("G25").Value = ws.Range("G25")
dsh.Range("G27").Value = ws.Range("G27")
dsh.Range("G29").Value = ws.Range("G29")
dsh.Range("G33").Value = ws.Range("G33")
dsh.Range("G35").Value = ws.Range("G35")
dsh.Range("G37").Value = ws.Range("G37")
dsh.Range("G39").Value = ws.Range("G39")
dsh.Range("G41").Value = ws.Range("G41")
dsh.Range("G43").Value = ws.Range("G43")
dsh.Range("G45").Value = ws.Range("G45")
dsh.Range("C54").Value = ws.Range("C54")
dsh.Range("C57").Value = ws.Range("C57")
dsh.Range("D60").Value = ws.Range("D60")
dsh.Range("D62").Value = ws.Range("D62")
dsh.Range("D64").Value = ws.Range("D64")
dsh.Range("G60").Value = ws.Range("G60")
dsh.Range("G62").Value = ws.Range("G62")
dsh.Range("G64").Value = ws.Range("G64")
' For save the PDF file
Dim sFolderName As String
Dim sFolderPath As String
Dim sPath As String
Dim Rng As Range
Dim Rng1 As Range
Dim pdfile As String
sFolderPath = "E:\SERVICE CENTER ACTIVITIES\INWARD\" sFolderName = Format(Date, "yyyy") & "\" & Format(DateAdd("M", -1, Now), "mmmm") & "\" sPath = sFolderPath & sFolderName
CreateFolders sPath Set Rng = dsh.Range("B2:H65")
pdfile = ws.Range("D7").Value & " - " & ws.Range("D11").Value & ".pdf"
pdfile = sPath & pdfile dsh.Visible = xlSheetVisible
Rng.ExportAsFixedFormat _ Type:=xlTypePDF, Filename:=pdfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
dsh.Visible = xlSheetHidden
'For update the Combobox1 list
Sheets("Inward_New").ComboBox1.List = Array("Concrete Equipment", "Paver", "XCMG")
'For clear all the fields
ws.Range("D11") = ""
ws.Range("D13") = ""
ws.Range("D15") = ""
ws.Range("D17") = ""
ws.Range("D19") = ""
ws.Range("D21") = ""
ws.Range("D23") = ""
ws.Range("D25") = ""
ws.Range("D27") = ""
ws.Range("D29") = ""
ws.Range("D31") = ""
ws.Range("D33") = ""
ws.Range("D35") = ""
ws.Range("D37") = ""
ws.Range("D39") = ""
ws.Range("D41") = ""
ws.Range("D43") = ""
ws.Range("D45") = ""
ws.Range("D47") = ""
ws.Range("D49") = ""
ws.Range("D51") = ""
ws.Range("G11") = ""
ws.Range("G13") = ""
ws.Range("G15") = ""
ws.Range("G17") = ""
ws.Range("G19") = ""
ws.Range("G21") = ""
ws.Range("G23") = ""
ws.Range("G25") = ""
ws.Range("G27") = ""
ws.Range("G29") = ""
ws.Range("G33") = ""
ws.Range("G35") = ""
ws.Range("G37") = ""
ws.Range("G39") = ""
ws.Range("G41") = ""
ws.Range("G43") = ""
ws.Range("G45") = ""
ws.Range("C54") = ""
ws.Range("C57") = ""
ws.Range("D60") = ""
ws.Range("D62") = ""
ws.Range("D64") = ""
ws.Range("G60") = ""
ws.Range("G62") = ""
ws.Range("G64") = ""
End Sub

Display More

On the above code it is not over write the values. It is creating new row only.

Can you please check and correct the above code for over write the values.

Posts by elsuji

Write the word to closed workbook where the values are matching

Write the word to closed workbook where the values are matching

Write the word to closed workbook where the values are matching

Write the word to closed workbook where the values are matching

Write the word to closed workbook where the values are matching

Write the word to closed workbook where the values are matching

Select Different range on same sheet for PDF conversion

Select Different range on same sheet for PDF conversion

Reminder mail trigger only for the target row where the values are modifying

Reminder mail trigger only for the target row where the values are modifying

Reminder mail trigger only for the target row where the values are modifying

Reminder mail trigger only for the target row where the values are modifying

Userform Listbox header display

Userform Listbox header display

Userform Listbox header display

Userform Listbox header display

Userform Listbox header display

Userform Listbox header display

Need code for edit and save the existing

Need code for edit and save the existing