Loop VBA with multiple cell references

[Tommy Snoberg Soderberg]

Hi,

I want to create a makro that loops until there's no more entries in my excelsheet where I get the data from. I.e. It should stop looping when there is a blank cell.
As a real beginner in VBA I'm not sure how I can insert som code into my existing code for that to work. I bet there's a real easy solution for it.

Sub Email_From_Excel_Attachments()

Dim emailApplication As Object
Dim emailItem As Object

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Sheets("Adresses").Select

emailItem.To = Range("B2").Value

emailItem.cc = Range("C2").Value

emailItem.Subject = Range("D2").Value & Date

emailItem.Body = Range("E2").Value

emailItem.Attachments.Add Range("F2").Value

emailItem.Send

End Sub

 

[mart37]

    Dim rng As Range
    Set rng = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    For Each c In rng
        emailItem.To = c 'b2
        emailItem.CC = c.Offset(0, 1) 'b2-->1 column to right ==> c2
        ...
    Next

 

[Tommy Snoberg Soderberg]

Hi,

I want to create a makro that loops until there's no more entries in my excelsheet where I get the data from. I.e. It should stop looping when there is a blank cell.
As a real beginner in VBA I'm not sure how I can insert som code into my existing code for that to work. I bet there's a real easy solution for it.

Sub Email_From_Excel_Attachments()

Dim emailApplication As Object
Dim emailItem As Object

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Sheets("Adresses").Select

emailItem.To = Range("B2").Value

emailItem.cc = Range("C2").Value

emailItem.Subject = Range("D2").Value & Date

emailItem.Body = Range("E2").Value

emailItem.Attachments.Add Range("F2").Value

emailItem.Send

End Sub

    Dim rng As Range
    Set rng = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    For Each c In rng
        emailItem.To = c 'b2
        emailItem.CC = c.Offset(0, 1) 'b2-->1 column to right ==> c2
        ...
    Next

Thank you! Where should I place this code in my existing macro? At the beginning? At the End?

 

[mart37]

Under: Sheets("Adresses").Select

 

[Norie]

Try this.

Sub Email_From_Excel_Attachments()
Dim rng As Range
Dim cl As Range
Dim emailApplication As Object
Dim emailItem As Object

    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    Set rng = Sheets("Adresses").Range("B2", Sheets("Addresses").Range("B" & Rows.Count).End(xlUp))

    For Each cl In rng.Cells
        With cl
            emailItem.To = .Value

            emailItem.cc = .Offset(, 1).Value

            emailItem.Subject = .Offset(, 2).Value & Date

            emailItem.Body = .Offset(, 3).Value

            emailItem.Attachments.Add .Offset(, 4).Value

            emailItem.Send
        End With
    Next cl
    
End Sub

 

[Tommy Snoberg Soderberg]

Thank you! Where should I place this code in my existing macro? At the beginning? At the End?

Unfortuatly I can't get it to work. It still only generates one Email although it seems to loop

 

[Tommy Snoberg Soderberg]

Try this.

Sub Email_From_Excel_Attachments()
Dim rng As Range
Dim cl As Range
Dim emailApplication As Object
Dim emailItem As Object

    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    Set rng = Sheets("Adresses").Range("B2", Sheets("Addresses").Range("B" & Rows.Count).End(xlUp))

    For Each cl In rng.Cells
        With cl
            emailItem.To = .Value

            emailItem.cc = .Offset(, 1).Value

            emailItem.Subject = .Offset(, 2).Value & Date

            emailItem.Body = .Offset(, 3).Value

            emailItem.Attachments.Add .Offset(, 4).Value

            emailItem.Send
        End With
    Next cl
   
End Sub

I get a subscript out of range error on this line

Set rng = Sheets("Adresses").Range("B2", Sheets("Addresses").Range("B" & Rows.Count).End(xlUp))

 

[dmt32]

Hi,
untested but see if this code does what you want

Sub Email_From_Excel_Attachments()

    Dim emailApplication    As Object, emailItem As Object
    Dim cell                As Range, rng        As Range
    Dim lastrow             As Long
   
    On Error GoTo myerror
    Set emailApplication = CreateObject("Outlook.Application")
   
    With Sheets("Adresses")
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row - 1
        Set rng = .Cells(2, 2).Resize(lastrow, 1)
    End With
   
    For Each cell In rng.Cells
        Set emailItem = emailApplication.CreateItem(0)
   
        With emailItem
            .To = cell.Value
            .cc = cell.Offset(, 1).Value
            .Subject = cell.Offset(, 2).Value & Date
            .Body = cell.Offset(, 3).Value
            .Attachments.Add cell.Offset(, 4).Value
            .Send
        End With
        Set emailItem = Nothing
    Next cell
myerror:
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave

 

[Tommy Snoberg Soderberg]

Hi,
untested but see if this code does what you want

Sub Email_From_Excel_Attachments()

    Dim emailApplication    As Object, emailItem As Object
    Dim cell                As Range, rng        As Range
    Dim lastrow             As Long
  
    On Error GoTo myerror
    Set emailApplication = CreateObject("Outlook.Application")
  
    With Sheets("Adresses")
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row - 1
        Set rng = .Cells(2, 2).Resize(lastrow, 1)
    End With
  
    For Each cell In rng.Cells
        Set emailItem = emailApplication.CreateItem(0)
  
        With emailItem
            .To = cell.Value
            .cc = cell.Offset(, 1).Value
            .Subject = cell.Offset(, 2).Value & Date
            .Body = cell.Offset(, 3).Value
            .Attachments.Add cell.Offset(, 4).Value
            .Send
        End With
        Set emailItem = Nothing
    Next cell
myerror:
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave

Thank you! This seems to work like a charm!

 

[dmt32]

Thank you! This seems to work like a charm!

You are welcome - glad we were able to help
appreciate feedback

Dave