Hi All,
I am trying to work out VBA code to do the following,
- Select Sheet “ABL”
- Row 10 has headings (column A to N)
- Sort data by Alphabet in Column H – values Critical, High, Medium and Low – Filters are on.
- Select all rows with Critical and High value in Column H.
- Copy this data.
- Select sheet “DBL” – Row 46 has headings and formats, same as of sheet ABL
- Clear all the rows from 47 onwards in sheet DBL – Row 1 – 46 has some graphs.
- Paste the data into DBL from row 47 onwards which was copied from sheet ABL with High and Critical Values (column H). Format must be same.
- Convert DBL into pdf – only rows with data.
- Email this pdf using tbl_Main_Email_List as To: and tbl_CC_Email_list as CC:.
I have worked out a code to do above but main issues are,
- Data will vary from week to week i.e. one week it may only have 5 rows with High and Critical and next week it may have 10, week after maybe 2.
- When the data is pasted into sheet DBL, it does not copy the borders.
Code is pasted below, it does not contain data sort, copy and paste information. It does contain some MsgBox Input which I would like to retain.
Code
Sub Email()
Application.ScreenUpdating = False
Sheets("DBL").Select
Dim AlertInput As String
AlertInput = InputBox("What is the Subject of Email?", "ABC - Project Dashboard Summary")
If AlertInput = vbNullString Then
MsgBox ("This Email request has been cancelled...")
Else
Dim v As Variant
v = Environ("Temp") & "\DBL_Summary.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=v
Dim toRange As Range
Dim ccRange As Range
Dim cl As Range
Dim toList As String
Dim ccList As String
Dim toListCnt As Long
Dim ccListCnt As Long
With Worksheets("Email.List")
Set toRange = .Range("A3", .Range("A3").End(xlDown))
toListCnt = WorksheetFunction.CountA(toRange)
Set ccRange = .Range("B3", .Range("B3").End(xlDown))
ccListCnt = WorksheetFunction.CountA(ccRange)
'MsgBox toListCnt
End With
'add main recipients to toList string
For Each cl In toRange
If toListCnt = 1 Then
toList = toList & cl.Value
Exit For
End If
toList = toList & "; " & cl.Value
Next cl
'add cc recipients to ccList string
For Each cl In ccRange
If ccListCnt = 1 Then
ccList = ccList & cl.Value
Exit For
End If
ccList = ccList & "; " & cl.Value
Next cl
'MsgBox toList
On Error Resume Next
With CreateObject("Outlook.Application").CreateItem(0)
.To = toList
.Cc = ccList
.Subject = "Weekly DBL Summary - " & AlertInput
.Body = ""
.Attachments.Add v
.display
End With
On Error GoTo 0
Kill v
End If
Application.ScreenUpdating = True
End SubApologies if it has been requested before but I could not find any specific reference. Any help in above will be appreciated.