I am trying to create automatic call for a sub based on unique values.
Column E The order is in column E
Sub FindDate()
Dim Cell As Range
'For Each Cell In ActiveSheet.Range("A1:A50")
' If Cell.Value = [Today()] Then
' Cell.Select
'ActiveCell.Offset(0, 4).Select
' End If
'Exit For
'Next
For Each Cell In ActiveSheet.Range("E2:E100")
If ActiveCell.Value = "" Then
End If
Exit For
Next
For Each Cell In ActiveSheet.Range("E2:E100")
If ActiveCell.Value = ActiveCell.Offset(-1, 0) Then
ActiveCell.Offset(1, 0).Select
Call EmailOrder
' ElseIf ActiveCell.Value <> ActiveCell.Offset(-1, 0) Then Call EmailOrder
'ElseIf ActiveCell.Value = "" Then Exit Sub
End If
Next Cell
End Sub
At the moment with this code (I know it is a really messy but I am just a VBA beginner) when I select the second PAU21001316 (from the picture) then it is calling my EmailOrder sub for PAU21001316 and PAU21001318 but not for the PAU21001319 and PAU21001320.
The code should do : If I select a cell, let's say PAU21001309 to look if the cell above ( or below) is the same value, if it's the same to move one cell below if not to run Call EmailOrder and after to move to the next cell and to do the same. Then If a cell is empty to stop.
The point is to run every unique value at the same time.
The other thing that I was trying to do (the first code as comment) was to go to the today's date and move 4 columns which will go to the first Order number. It's moving the active cell but after that do nothing, just looping.
If anyone can help me to finish my code I will be grateful.
Sub EmailOrder(c As Range)
Dim ActiveC As Variant
Dim DirFile As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim xOutMsg As String
Dim Timenow As String
Dim signImageFolderName As String
Dim completeFolderPath As String
Dim colFiles As New Collection
'GetFiles "C:\xxx\", ActiveC & ".pdf", True, colFiles
'If colFiles.Count > 0 Then
' 'work with found files
'End If
If Time < TimeValue("12:00:00") Then
Timenow = "Good Morning"
ElseIf Time > TimeValue("12:00:00") And Time < TimeValue("17:00:00") Then
Timenow = "Good Afternoon"
Else
Timenow = "Good Evening"
End If
xOutMsg = Timenow & ", <br> <br> xxx<br/>"
ActiveC = Application.ActiveCell.Value
Dim sRes As String
Dim po As Range
Dim rg As Range
Dim b2 As Range
Set po = ActiveCell.Offset(0, 3)
Set rg = Sheets("Email").Range("B1:D200")
Set b2 = po
sRes = Application.VLookup(b2, rg, 3, True)
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
DirFile = "C:\xxx\" & ActiveC & ".pdf"
If Dir(DirFile) = "" Then
MsgBox "File does not exist", vbCritical
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\xxx.htm"
signImageFolderName = "xxxfiles"
completeFolderPath = Environ("appdata") & "\Microsoft\Signatures\" & signImageFolderName
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Signature = VBA.Replace(Signature, signImageFolderName, completeFolderPath)
Else
Signature = ""
End If
'Create Outlook email with attachment
On Error Resume Next
With OutMail
.To = sRes
.CC = ""
.BCC = ""
.Subject = "xxx " & ActiveC
.HTMLBody = xOutMsg & "<br>" & Signature
.Attachments.Add "C:xxx\" & ActiveC & ".pdf"
.Display
End With
Call FindDate
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
This is the main code, made form different codes. The main purpose is to get the value of the active cell and look in to the folder (I couldn't do to look in to the sub folders) for the file name.pdf and the to attach it to the email. The other part is to look for the supplier name in column H and VLOOKUP to another sheet "Email" for the supplier email and add it to the "To" section. The other code is for the signature and the body of the email.
The code is working but only when I select the specific cell. But it will be faster if is doing every PO for the day automatically.
Try this:
Sub Tester()
Dim f As Range, c As Range
Set f = Range("A1:A50").Find(Date) 'Look for today's date
If f Is Nothing Then Exit Sub 'Today not found....
Set c = f.Offset(0, 4) 'move over to Col E
Do While Len(c.Value) > 0
If c.Offset(1, 0).Value <> c.Value Then
EmailOrder c 'pass cell directly to your called sub
End If
Set c = c.Offset(1, 0) 'move down one row
Loop
End Sub
Sub EmailOrder(c As Range)
Const FLDR As String = "C:\xxx\" 'start search here
Dim ActiveC As Variant
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim sRes As String
Dim po
Dim rg As Range, b2 As Range
Dim signImageFolderName As String, completeFolderPath As String
Dim colFiles As Collection
ActiveC = c.Value
po = c.Offset(0, 3).Value
Set rg = Sheets("Email").Range("B1:D200")
sRes = Application.VLookup(po, rg, 3, True) 'False?
Set colFiles = GetMatches(FLDR, ActiveC & ".pdf") 'find any matches
If colFiles.Count = 0 Then
MsgBox "File '" & ActiveC & ".pdf' does not exist", vbCritical
Exit Sub
End If
'what to do if >1 files found?
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\xxx.htm"
signImageFolderName = "xxxfiles"
completeFolderPath = Environ("appdata") & "\Microsoft\Signatures\" & signImageFolderName
If Dir(SigString) <> "" Then
Signature = VBA.Replace(GetBoiler(SigString), signImageFolderName, completeFolderPath)
End If
With OutMail
.To = sRes
.CC = ""
.BCC = ""
.Subject = "xxx " & ActiveC
.HTMLBody = TimeGreeting & ", <br> <br> xxx<br/>" & Signature
.Attachments.Add colFiles(1).Path 'assuming you only want the first match if >1
.Display
End With
Call FindDate
End Sub
Function TimeGreeting() As String
If Time < TimeValue("12:00:00") Then
TimeGreeting = "Good Morning"
ElseIf Time > TimeValue("12:00:00") And Time < TimeValue("17:00:00") Then
TimeGreeting = "Good Afternoon"
Else
TimeGreeting = "Good Evening"
End If
End Function
Function for file searching:
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder '<< start with the top-level folder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1 '<< remove from queue
For Each f In fldr.Files 'check all files
If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
Next f
If subFolders Then 'add subfolders to queue for listing
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
Loop
Set GetMatches = colFiles
End Function