HI , are you using Acces database ?
Posts by Dogaru
-
-
Hi all ,
Just asking maybe someone else already done this . I am having issues with an user form to load the fiscal week when it intilializes. I am now using iso function in vba but my fiscal year start the 1st of July and it saying is still in week 52 and it should be week 1. Would you have any ideas on how to make this work ?
-
I'm at work now , I will do it when I have a minute.
-
-
Give it a try now
Code
Display MoreSet OutMail = OutApp.CreateItem(0) toList = Cells(i, 4) 'gets the recipient from col B 'CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10) eSubject = "Calibration remainder for your " & Cells(i, 5) & " Batching Plant " eBody = "<font style=""font-family:Cambria; font-size:12pt;""<font> Dear Sir, <br><br>" _ & "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _ & "Your " & "<b>" & Worksheets("Data").Cells(i, "E").Value & "</b>" _ & " Batching Plant calibration certificate is going to expire soon ( within " _ & "<b>" & Worksheets("Data").Cells(i, "I").Value & "</b>" & " days ).<br><br>" _ & "Plant Last calibration done date is " & "<b>" & Worksheets("Data").Cells(i, "G").Value & "</b>" _ & " and next due date is " & "<b>" & Worksheets("Data").Cells(i, "H").Value & "</b>" & ".<br><br>" _ & "Kindly do the calibration on time for accurate batching.<br><br>" & S "<font style=""font-family:Cambria; font-size:12pt;""<font><font style=""font-family:Cambria; font-size:12pt;""</font>" On Error Resume Next With OutMail .To = toList .CC = CCList .BCC = "" .Subject = eSubject .HTMLBody = eBody .Display ' ********* Creates draft emails. Comment this out when you are ready '.Send '********** UN-comment this when you are ready to go live End With
-
You have closed the font code , the text you want to format needs to be inside <font>your text here </font>, I have modified your code , try it
Code
Display MoreSet OutMail = OutApp.CreateItem(0) toList = Cells(i, 4) 'gets the recipient from col B 'CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10) eSubject = "Calibration remainder for your " & Cells(i, 5) & " Batching Plant " eBody = "<font style=""font-family:Cambria; font-size:12pt & "" Dear Sir, <br><br>" _ & "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _ & "Your " & "<b>" & Worksheets("Data").Cells(i, "E").Value & "</b>" _ & " Batching Plant calibration certificate is going to expire soon ( within " _ & "<b>" & Worksheets("Data").Cells(i, "I").Value & "</b>" & " days ).<br><br>" _ & "Plant Last calibration done date is " & "<b>" & Worksheets("Data").Cells(i, "G").Value & "</b>" _ & " and next due date is " & "<b>" & Worksheets("Data").Cells(i, "H").Value & "</b>" & ".<br><br>" _ & "Kindly do the calibration on time for accurate batching.<br><br>" & S </font> On Error Resume Next With OutMail .To = toList .CC = CCList .BCC = "" .Subject = eSubject .HTMLBody = eBody .Display ' ********* Creates draft emails. Comment this out when you are ready '.Send '********** UN-comment this when you are ready to go live End With
-
-
I have sorted the issue, the problem was that the condition that would trigger the module was on column 5 and I had another 5 columns after it , as soon as it met the condition it only added the cell values from the last row up to column 5 where the condition was met and did not added the rest of the last rows in the columns . In order the make it work I have delayed the macro to run for 5 second giving enough time to add data to populate the active sheet, now it works perfect , I have posted the working code maybe someone else has the same issue, I have used the following code:
Code
Display MoreOption Explicit Sub sendmail() Application.OnTime Now + TimeSerial(0, 0, 10), "Mail_small_Text_OutlookMail_small_Text_Outlook" End Sub Option Explicit Sub Mail_small_Text_OutlookMail_small_Text_Outlook() Dim lastRow As Long 'lastRow = Range("A" & .Rows.count).End(xlUp).Row lastRow = ListObjects("Table2234").Range.Columns(1).Cells.Find("*", Searchorder:=xlByRows, searchdirection:=xlPrevious).Row Dim xOutApp As Object Dim xOutMail As Object Dim xmailbody As String Dim strbody As String Set xOutApp = CreateObject("Outlook.Application") Set xOutMail = xOutApp.CreateItem(0) strbody = Cells(lastRow, 1).Value & "Shift" & vbNewLine & _ Cells(lastRow, 2).Value & "Date" & vbNewLine & _ Cells(lastRow, 3).Value & "Raised By" & vbNewLine & _ Cells(lastRow, 4).Value & "Month" & vbNewLine & _ Cells(lastRow, 5).Value & "Condition" & vbNewLine & _ Cells(lastRow, 6).Value & "Opened/Closed" & vbNewLine & _ Cells(lastRow, 7).Value & "Raised By" & vbNewLine & _ Cells(lastRow, 8).Value & "Area" & vbNewLine & _ Cells(lastRow, 9).Value & "Near Miss" & vbNewLine & _ Cells(lastRow, 10).Value & "Action" xmailbody = strbody On Error Resume Next With xOutMail .to = "xxxx" .cc = "xxx" .BCC = "" .Subject = "Serious Near Miss" .Body = xmailbody .display End With On Error GoTo 0 Set xOutMail = Nothing Set xOutApp = Nothing End Sub
-
-
Hello,
I have an issue with trying to insert multiple ranges into an email body. I have the conditions if a cell has a certain value the in sends an email also when it sends the mail it copies the data from last row and it inserts it into the email body , the weird thing is that when I run the sub from the script it works perfectly(picture "from script") BUT when I insert the data from the user form and meets the condition it only gets the data from the first 5 columns (picture "from userform"). If someone can help me I would be very grateful. Thank you in advance
Code
Display MoreDim xrg As Range Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Target.Cells.count > 1 Then Exit Sub Set xrg = Intersect(Range("e:e"), Target) If xrg Is Nothing Then Exit Sub If Target.Value = "Serious Near Miss" Then Call Mail_small_Text_Outlook End If End Sub Sub Mail_small_Text_Outlook() Dim lastRow As Long 'lastRow = Range("A" & .Rows.count).End(xlUp).Row lastRow = ListObjects("Table2234").Range.Columns(1).Cells.Find("*", Searchorder:=xlByRows, searchdirection:=xlPrevious).Row Dim xOutApp As Object Dim xOutMail As Object Dim xmailbody As String Dim strbody As String Set xOutApp = CreateObject("Outlook.Application") Set xOutMail = xOutApp.CreateItem(0) strbody = Cells(lastRow, 1).Value & "Shift" & vbNewLine & _ Cells(lastRow, 2).Value & "Date" & vbNewLine & _ Cells(lastRow, 3).Value & "Raised By" & vbNewLine & _ Cells(lastRow, 4).Value & "Month" & vbNewLine & _ Cells(lastRow, 5).Value & "Condition" & vbNewLine & _ Cells(lastRow, 6).Value & "Opened/Closed" & vbNewLine & _ Cells(lastRow, 7).Value & "Raised By" & vbNewLine & _ Cells(lastRow, 8).Value & "Area" & vbNewLine & _ Cells(lastRow, 9).Value & "Near Miss" & vbNewLine & _ Cells(lastRow, 10).Value & "Action" xmailbody = strbody On Error Resume Next With xOutMail .to = "xxxx" .cc = "xxx" .BCC = "" .Subject = "Serious Near Miss" .Body = xmailbody .display End With On Error GoTo 0 Set xOutMail = Nothing Set xOutApp = Nothing End Sub
-
just that post, thanks again RoyUk
-
hello , would there be any posibility to remove attached file above as I just realised there is some sensitive data in the workbook, thank you
-
thank you Roy , I have also attached the worksheet in a previous post
-
also I have attached the example workbook
-
Hi RoyUK , I have pasted the code from userform below : as I said in the previous comment , If there is any possibility to search as you type when typing in the combobox as the database is large and it only get larger ,
Code
Display MorePrivate Sub Advice_Click() If box9.Text = "Did not isolate tools before break" Then box10.Text = "Always isolate tools before break" End If If box9.Text = "Did not isolate tools before break" Then box10.Text = "Always isolate tools before break" End If If box9.Text = "Did not used Zone Stop Before Clearing Jam" Then box10.Text = "Always use Zone-Stop before clearing jam on high speed line" End If If box9.Text = "Did not disconnect saw before going to break" Then box10.Text = "Always disconnect saw before going to break" End If If box9.Text = "Stacked Pallets Over 5 high on His Own" Then box10.Text = "Always ask for help if the stack is more than 5 high" End If If box9.Text = "Carrying a pallet instead of rolling it" Then box10.Text = "Always roll the pallet when moving it" End If If box9.Text = "De-stacking pallets over 5 high on his own" Then box10.Text = "Always ask for help when De-Stacking pallets over 5 high" End If If box9.Text = "Did not empty general waste skip" Then box10.Text = "When Full , empty the general waste skip" End If If box9.Text = "Wood chip bin not emptied" Then box10.Text = "When full , please empty the bin" End If If box9.Text = "Plastic on the floor" Then box10.Text = "Put plastic in plastic bin" End If If box9.Text = "Banding left on the floor" Then box10.Text = "Put the banding in the bin" End If If box9.Text = "Refusing A Reasonable Request" Then box10.Text = "When asked to do something reasonable , please do it" End If If box9.Text = "Using his phone" Then box10.Text = "We are not allowed to use phone during working hours" End If If box9.Text = "Drinking/Eating in the smoking area" Then box10.Text = "Please, do not drink/eat in smoking area" End If If box9.Text = "Spitting" Then box10.Text = "Please, do not spit" End If If box9.Text = "Idiling - Not spending time on his workstation" Then box10.Text = "Please, spend more time on your bench" End If If box9.Text = "Coming late from break" Then box10.Text = "Please, watch your time keeping" End If If box9.Text = "Leaving early for break" Then box10.Text = "Please, watch your time keeping" End If If box9.Text = "Pushing request button when already having pallet on the bench" Then box10.Text = "Please, repair your pallet first and then ask for another one" End If If box9.Text = "Did Not Called Yard Lockdown" Then box10.Text = "Before entering the yard , always call for yard lockdown" End If If box9.Text = "Did Not Hang Tools Back" Then box10.Text = "Always hang back your tools" End If If box9.Text = "Did Not Followed 1-4-1 Blade Procedure" Then box10.Text = "Always give the blade or the gloves back so you can have a new one" End If If box9.Text = "Did Not Removed All Shrink Wrap/Labels From Pallets" Then box10.Text = "Take plastic/Labels off" End If If box9.Text = "Loaded Infeed 21 High" Then box10.Text = "Please, load 2o pallets to avoid damaging machinery" End If If box9.Text = "Left Key Press By COSHH Cabinet Open" Then box10.Text = "Always close key press" End If If box9.Text = "Left Blade Bag On Top Of Timber" Then box10.Text = "Please, keep the bag with yourself" End If If box9.Text = "Left COSHH Cabinet Open" Then box10.Text = "Please, always close COSHH CAbinet" End If If box9.Text = "Drive With Open Forks By Ramp" Then box10.Text = "When driving , close your forks" End If If box9.Text = "Did Not Used Crossing From Car Park To Entrance" Then box10.Text = "Always use the walkway" End If If box9.Text = "Causing Too Many Jams Because Due To Not Removing Pallets That Cannot Travel" Then box10.Text = "Remove pallets that cannot travel" End If If box9.Text = "Nail Filter On Klippa 1 Not Cleaned" Then box10.Text = "Please clean" End If If box9.Text = "Nail Filter On Klippa 2 Not Cleaned" Then box10.Text = "Please clean" End If If box9.Text = "Nail Crates Not Filled" Then box10.Text = "Please fill nail crates" End If If box9.Text = "Not Reporting a Safety Defect During Pre-start Check" Then box10.Text = "Always report safety defects" End If If box9.Text = "Did not isolate tools before break" Then box10.Text = "Always isolate tools before going for break" End If If box9.Text = "Entering The Warehouse Without Earplugs" Then box10.Text = "Always wear earplugs before entering the warehouse" End If If box9.Text = "Not Wearing Apron While Working On The Bench" Then box10.Text = "Always wear your apron when working on the bench" End If If box9.Text = "Working On Inspection Without Using Impact Gloves" Then box10.Text = "Always use the right gloves when working on inspection" End If If box9.Text = "Entering The Warehouse Without Glasses" Then box10.Text = "Always put your glasses on before entering the warehouse" End If If box9.Text = "Working With Damaged Gloves " Then box10.Text = "Ask for a new pair" End If If box9.Text = "Working With Damaged Apron " Then box10.Text = "Ask for a new apron" End If If box9.Text = "Working With Damaged Boots" Then box10.Text = "Ask for a new pair" End If If box9.Text = "Did Not Clean Up His Workstation" Then box10.Text = "Make sure you keep clean your workstation" End If If box9.Text = "Did not empty general waste skip" Then box10.Text = "Please empty the general waste skip" End If If box9.Text = "Wood chip bin not emptied" Then box10.Text = "emptied the wood chip bin" End If If box9.Text = "Plastic on the floor" Then box10.Text = "Put plastic in the bin" End If If box9.Text = "Banding left on the floor" Then box10.Text = "Put banding in the general waste skip" End If End Sub Private Sub box1_Change() Dim wks As Worksheet Set wks = Sheet2 Select Case Me.box1 Case "A" Me.box6.RowSource = "A" Case "B" Me.box6.RowSource = "B" Case "C" Me.box6.RowSource = "d" Case "POLT" Me.box6.RowSource = "allstaff" Case "Tesco" Me.box6.RowSource = "tescostaff" Case "" Me.box6.Text = "" End Select Select Case Me.box1 Case "A" Me.box3.RowSource = "aa" Case "B" Me.box3.RowSource = "bb" Case "C" Me.box3.RowSource = "cc" Case "POLT" Me.box3.RowSource = "polt" Case "Tesco" Me.box3.RowSource = "tesco" Case "" Me.box3.Text = "" Case Else End Select End Sub Private Sub box5_Change() Dim wks As Worksheet Set wks = Sheet2 Select Case Me.box5 Case "Isolation" Me.box9.RowSource = "isolation" Case "Manual Handiling" Me.box9.RowSource = "manual_handelingn" Case "HouseKeeping" Me.box9.RowSource = "housekeepingn" Case "Behaviour" Me.box9.RowSource = "behaviourn" Case "Process" Me.box9.RowSource = "processn" Case "P.P.E" Me.box9.RowSource = "ppen" Case "" Me.box9.Text = "" Case Else End Select End Sub Private Sub CommandButton1_Click() TargetSheet = box4.Text If TargetSheet = "" Then Exit Sub End If Worksheets(TargetSheet).Activate lastrow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row ActiveSheet.Cells(lastrow + 1, 1).Value = box1.Text ActiveSheet.Cells(lastrow + 1, 2).Value = thedate.Text ActiveSheet.Cells(lastrow + 1, 3).Value = box3.Text ActiveSheet.Cells(lastrow + 1, 4).Value = box4.Text ActiveSheet.Cells(lastrow + 1, 5).Value = box5.Text ActiveSheet.Cells(lastrow + 1, 6).Value = box11.Text ActiveSheet.Cells(lastrow + 1, 7).Value = box6.Text ActiveSheet.Cells(lastrow + 1, 8).Value = box7.Text ActiveSheet.Cells(lastrow + 1, 9).Value = box9.Text ActiveSheet.Cells(lastrow + 1, 10).Value = box10.Text ActiveSheet.Cells(lastrow + 1, 11).Value = count.Text MsgBox ("Data Added To M.O.T Tracker Successfully") ListBox1.ColumnCount = 12 ListBox1.RowSource = "A1:K165356" End Sub Private Sub CommandButton3_Click() Dim icontrol As Control For Each icontrol In Me.Controls If icontrol.Name Like "box*" Then icontrol = vbNullString Next End Sub Private Sub CommandButton4_Click() Dim iexit As VbMsgBoxResult iexit = MsgBox(" Are You Sure You Want To Leave South Ockendon M.O.T Tracker ?", vbQuestion + vbYesNo, "South Ockendon M.O.T Tracker") If iexit = vbYes Then Unload Me End If End Sub Private Sub ListBox1_Click() End Sub Private Sub UserForm_Initialize() Dim wks As Worksheet Dim AddNew As Range Set wks = Sheet2 ListBox1.ColumnCount = 10 ListBox1.RowSource = "A1:J165356" 'MOT Type box5.AddItem ("") box5.AddItem ("Isolation") box5.AddItem ("Manual Handiling") box5.AddItem ("HouseKeeping") box5.AddItem ("Behaviour") box5.AddItem ("Process") box5.AddItem ("P.P.E") 'Shift box1.AddItem ("") box1.AddItem ("A") box1.AddItem ("B") box1.AddItem ("C") box1.AddItem ("POLT") box1.AddItem ("Tesco") 'month box4.AddItem ("") box4.AddItem ("January") box4.AddItem ("February") box4.AddItem ("March") box4.AddItem ("April") box4.AddItem ("May") box4.AddItem ("June") box4.AddItem ("July") box4.AddItem ("August") box4.AddItem ("September") box4.AddItem ("October") box4.AddItem ("November") box4.AddItem ("December") 'area box7.AddItem ("") box7.AddItem ("Bench") box7.AddItem ("Yard") box7.AddItem ("Warehouse") box7.AddItem ("Inspection") 'mot category box11.AddItem ("") box11.AddItem ("Opened") box11.AddItem ("Closed") 'count count.Text = 1 'box 2 date thedate.Text = Format(Date, "ddd d mmm yyyy") End Sub
-
Hi guys ,
I am new to VBA and I would need some help with a thing I want to improve on my project.
I have dependant combobox in my data entry form and the database is quite big and it is time consuming going trough the list to add the string . The combobox match text only picks up the first letters of the string so I am not able to type a word and have a result in the combo dropdown list, I have looked over some tutorials but with no success, do you think you can help me , if needed I can attach the workbook