Posts by mvj1996

mvj1996 · Aug 30th 2016

Re: Compare 2 columns in different sheets, and Copy entire rows into new sheets

I found My Error. I had to add .EntireRow.Copy. It works now.

Code

ThisWorkbook.RefreshAll
  Dim rng As Range, c As Range, cfind As Range
  
       
      On Error Resume Next
     Worksheets("New").Cells.Clear
     With Worksheets("Weekly")
         Set rng = .Range(.Range("C1"), .Range("c1").End(xlDown))
         For Each c In rng
         c = Replace(c, " ", "")
         With Worksheets("SharePoint")
             Set cfind = .Columns("C:Z").Cells.Find _
             (what:=c.Value, lookat:=xlWhole)
             If cfind Is Nothing Then
                 c.Resize(1, 26).Copy Worksheets(3).Cells(Worksheets(3).Rows.Count, "A").End(xlUp).Offset(1, 0)
             End If
         End With 'weekly
         Next c
         Application.CutCopyMode = False
     End With 'sharepoint
     Worksheets("Cancels").Cells.Clear
     With Worksheets("Sharepoint")
         Set rng = .Range(.Range("C2"), .Range("c2").End(xlDown))
         For Each c In rng
         c = Replace(c, " ", "")
         With Worksheets("Weekly")
             Set cfind = .Columns("C:Z").Cells.Find _
             (what:=c.Value, lookat:=xlWhole)
             If cfind Is Nothing Then
                 c.Resize(1, 26).Copy Worksheets(4).Cells(Worksheets(4).Rows.Count, "A").End(xlUp).Offset(1, 0)
             End If
         End With 'weekly
         Next c
         Application.CutCopyMode = False
     End With 'sharepoint
 End Sub

Display More

mvj1996 · Aug 30th 2016

Hello All,

I'm trying to compare two columns in one sheet with two columns in another sheet. I want to show the unique items in the comparison in a new sheet. I want to copy the unique items to two new sheets.

Example: compare columns C & Z in sheet 1 with columns C & Z in sheet 2. the differences of what's on sheet 2 , but not sheet 1, post to a new sheet, and the differences of what's on sheet 1 but not on sheet 2 post into a new sheet.

The code below works, but it is not copying the entire rows. It is pasting the results in column A of the new sheet, but it is starting with column C and not copying data in columns A & B.

Code

ThisWorkbook.RefreshAll
 Dim rng As Range, c As Range, cfind As Range
 
      
     On Error Resume Next
    Worksheets("New").Cells.Clear
    With Worksheets("Weekly")
        Set rng = .Range(.Range("C1"), .Range("c1").End(xlDown))
        For Each c In rng
        c = Replace(c, " ", "")
        With Worksheets("SharePoint")
            Set cfind = .Columns("C:Z").Cells.Find _
            (what:=c.Value, lookat:=xlWhole)
            If cfind Is Nothing Then
                c.Resize(1, 26).Copy Worksheets(3).Cells(Worksheets(3).Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End With 'weekly
        Next c
        Application.CutCopyMode = False
    End With 'sharepoint
    Worksheets("Cancels").Cells.Clear
    With Worksheets("Sharepoint")
        Set rng = .Range(.Range("C2"), .Range("c2").End(xlDown))
        For Each c In rng
        c = Replace(c, " ", "")
        With Worksheets("Weekly")
            Set cfind = .Columns("C:Z").Cells.Find _
            (what:=c.Value, lookat:=xlWhole)
            If cfind Is Nothing Then
                c.Resize(1, 26).Copy Worksheets(4).Cells(Worksheets(4).Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End With 'weekly
        Next c
        Application.CutCopyMode = False
    End With 'sharepoint
End Sub

Display More

mvj1996 · Aug 30th 2016

Re: Add Links to HTML emal body content

Quote

I'm still stuck with adding links to HTML email body. I need to have a string of content and then have two links with friendly names as "click here", and then a closing message. Any suggestions? I think there is something wrong in how I captured the links. The email displays with recipients, but does not display the body of the message or links. Thanks in advance for any assistance.

Code

strbody = "RESPONSE REQUIRED BY WEDNESDAY OF EACH WEEK." & vbNewLine & vbNewLine & _
                    "Confirmation of the occurrence or non-occurrence of an ABC Event is required weekly. You are receiving this email because you are listed as a contact for one or more active ABC policies."


strclosing = "For questions not covered in the training materials [mailto:[email protected]]." & vbNewLine & vbNewLine & _
                    "Thank you for your help in ensuring ABC adherence with current ABC policies, procedures and regulations." & vbNewLine & vbNewLine & _
                    "THE ABC OPERATIONS TEAM"
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
            With OutMail
                    .To = strEmailTo
                    .CC = strCCTo
                    .BCC = strBCCTo
                    .BodyFormat = olFormatHTML
                    .HTMLBody = strbody
                    .HTMLBody = "<a href ='" & [URL]http://sharepoin2.ABC.com/sites/WFO_LPI/SitePages/Redirect.aspx[/URL] & "'>Click Here</a>" & _
                    .HTMLBody = "<a href ='" & [URL]http://sharepoint2.ABC.com.com/sites/WFO_LPI/_layouts/PowerPoint.aspx?PowerPointView=ReadingView&PresentationId=/sites/WFO_LPI/Shared%20Documents/Weekly%20Confirmation%20Process%20Deck.pptx&Source=http%3A%2F%2Fsharepoint2%2Eabc%2Ecom%2Fsites%2FWFO%5FLPI%2FShared%2520Documents%2FForms%2FAllItems%2Easpx&DefaultItemOpen=1&DefaultItemOpen=1[/URL] & "'>Click Here</a>" & _
                    .HTMLBody = strclosing
                    .Subject = "Please Respond"
                    'You can add other files by uncommenting the following line.
                    '.Attachments.Add
                    .Display

Display More

mvj1996 · Aug 29th 2016

Hello All,

I am attempting to create a email macros with links and body text. I have 3 hyperlinks that I need to include at different points in the body content. 2 to show Text To Display "Click Here", and one to an email DG. Any suggestions.

I attached my HTML body content below, and put placeholders in the spot I need to attach a link. I can't seem to figure out the best way. I have tried <a href="mailto:[email protected]">Send me an email</a>.

Code

strbody = "RESPONSE REQUIRED BY WEDNESDAY OF EACH WEEK." & vbNewLine & vbNewLine & _                    "Confirmation of the occurrence or non-occurrence of an XYZ Event Tracking is required weekly. You are receiving this email because      you are listed as a contact for one or more active account." & vbNewLine & _                    "To respond: [Link Here]." & vbNewLine & _                    "To access process training materials: [Link here]." & vbNewLine & _                    "For questions not covered in the training materials, send your email to: [Email Here}." & vbNewLine & vbNewLine & _

mvj1996 · Aug 29th 2016

Re: Transpose unique values

Thanks again for your help. I am new at this and had been struggling for hours.

I do have one last question. Is there a better way to add a link into the body of an message for a email? I copied and paste the address in the message, but would like to name the link or paste it to where the link thread is not showing in the email.

mvj1996 · Aug 29th 2016

Re: Transpose unique values

Quote

Thanks Trevor. Those additional steps worked perfectly. I appreciate your help.

Code

Sub Mail_Workbook_1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lngLastRow  As Long
    Dim rngMyCell   As Range
    Dim objEmailTo  As Object
    Dim strEmailTo  As String
    Dim objCCTo     As Object
    Dim strCCTo     As String
    Dim strbody As String
     
    Application.ScreenUpdating = False
     
     'Prepare an unique, case sensitive list of 'EmailTo' recipients
    Set objEmailTo = CreateObject("Scripting.Dictionary")
     
    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "AA").End(xlUp).Row
     
    For Each rngMyCell In Worksheets("Sheet1").Range("AA3:AA" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objEmailTo.Exists(CStr(rngMyCell)) = False Then
                objEmailTo.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell
     
    strEmailTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objEmailTo.Items)), ";")
    
     'Prepare an unique, case sensitive list of 'CCTo' recipients
    Set objCCTo = CreateObject("Scripting.Dictionary")
     
    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "AC").End(xlUp).Row
     
    For Each rngMyCell In Worksheets("Sheet1").Range("AC3:AC" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objCCTo.Exists(CStr(rngMyCell)) = False Then
                objCCTo.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell
     
    strCCTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objCCTo.Items)), ";")
     
    Application.ScreenUpdating = True
    strbody = "RESPONSE REQUIRED." & vbNewLine & vbNewLine & _
                       
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
            With OutMail
                    .To = strEmailTo
                    .CC = strCCTo
                    .BCC = ""
                    .Subject = "Please Review"
                    .Body = strbody
                    'You can add other files by uncommenting the following line.
                    '.Attachments.Add
                    .Display
             End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Display More

mvj1996 · Aug 29th 2016

Re: Send email to multiple recipients

Thanks Trevor. I actually combined info from two scripts together. It displayed the email, but pulled in duplicate addresses. I need to transpose unique email addresses. Some recipients addresses appear more than once in the file. Any Suggestions?

Code

Sub Mail_Workbook_1Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim CCTo As String
    Dim strbody As String
    
    EmailTo = Join(Application.Transpose(Worksheets("Sheet1").Range("AA3:AA65536").Value), ";")
    CCTo = Join(Application.Transpose(Worksheets("Sheet1").Range("AC3:AC65536").Value), ";")
    
    strbody = "RESPONSE REQUIRED." & vbNewLine & vbNewLine & _
                    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
            With OutMail
                    .To = EmailTo
                    .CC = CCTo
                    .BCC = ""
                    .Subject = "Please Review"
                    .Body = strbody
                    'You can add other files by uncommenting the following line.
                    '.Attachments.Add
                    .Display
             End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Display More

mvj1996 · Aug 29th 2016

Re: Send email to multiple recipients

Thanks Trevor76. I was able to get it too work. However, it is pulling in duplicate email addresses. Any suggestions with transposing unique values.

EmailTo = Join(Application.Transpose(Worksheets("SharePoint").Range("AA3:AA65536").Value), ";")
CCTo = Join(Application.Transpose(Worksheets("SharePoint").Range("AC3:AC65536").Value), ";")

mvj1996 · Aug 29th 2016

I'm trying too write this code to pull only unique values. Any suggestions?

EmailTo = Join(Application.Transpose(Worksheets("SharePoint").Range("AA3:AA65536").Value), ";")
CCTo = Join(Application.Transpose(Worksheets("SharePoint").Range("AC3:AC65536").Value), ";")

mvj1996 · Aug 28th 2016

I'm trying to create the code below to send emails to multiple recipients listed in a worksheet column and CC recipients in another column. I don't get an error, but it is not displaying nor sending the email. I'm missing something somewhere.

Code

Sub EmailReminder()
        
    Dim oOL As Outlook.Application, oMail As Outlook.MailItem, oNS As Outlook.Namespace
    Dim oMapi As Outlook.MAPIFolder, oExpl As Outlook.Explorer
    Dim sBody As String, sRecip As String, sSubj As String, dDate As String, bSend As Boolean
    Dim oWS As Worksheet, r As Long, i As Long, sStart As String
    
    If MsgBox("Send directly(Y) or display(N)?", vbYesNo) = vbYes Then bSend = True
        
    On Error Resume Next
       
    Set oWS = Sheet1
    Set oOL = New Outlook.Application
    Set oExpl = oOL.ActiveExplorer
    
    If TypeName(oExpl) = "Nothing" Then
       Set oNS = oOL.GetNamespace("MAPI")
       Set oMapi = oNS.GetDefaultFolder(olFolderInbox)
       Set oExpl = oMapi.GetExplorer
    End If
    
    With oWS.Range("Z3").End(xlDown)
        r = .CurrentRegion.Rows.Count
        For i = 3 To r
            dDate = .Cells(i, 30)
         If dDate = True Then
            sRecip = Join(Application.Transpose(Worksheets("Sheet1").Range("AA:AA").Value), ";")
            sSubj = "Please Review"
            sBody = "RESPONSE REQUIRED." & vbNewLine & vbNewLine & _                    
                    If bSend = False Then
                        Set oMail = oOL.CreateItem(olMailItem)
                        With oMail
                            .Subject = sSubj
                            .Date = sDate
                            .Body = sBody
                            .Recipients.Add sRecip
                            .Display 'NOT.Send
                        End With
                    End If
      End If
      Next i
    End With
End Sub

Display More