copy the command button and macro for multiple rows

[bigproblem]

How can I copy the command button and macro for multiple rows ?

Private Sub CommandButton1_Click()
Dim Outlook As Object
Dim Appointment As Object
Dim Category As String
Dim Time As Variant

Const Item = 1

Set Outlook = CreateObject("Outlook.Application")
Set Appointment = Outlook.CreateItem(1)
Time = "08:30AM"

Appointment.Location = Range("a2") & ", " & Range("d2") & ", " & Range("e2")

Appointment.Subject = Range("i2")

Appointment.Start = DateAdd("d", 350, Range("b2")) & " " & Time

Appointment.Body = Range("a2") & ", " & Range("b2") & ", " & Range("c2") &
", " & Range("d2") & ", " & Range("e2")



Appointment.ReminderPlaySound = True
Appointment.Display

'Outlook.quit
'Set Outlook = Nothing
End Sub

 

[Bernie Deitrick]

For the active cell's row:

'*************************************
Private Sub CommandButton1_Click()
Dim Outlook As Object
Dim Appointment As Object
Dim Category As String
Dim Time As Variant
Dim myR As Long

Const Item = 1

myR = Activecell.Row

Set Outlook = CreateObject("Outlook.Application")
Set Appointment = Outlook.CreateItem(1)
Time = "08:30AM"

Appointment.Location = Range("a" & myR) & ", " & Range("d" & myR) & ", " &
Range("e" & myR)

Appointment.Subject = Range("i" & myR)

Appointment.Start = DateAdd("d", 350, Range("b" & myR)) & " " & Time

Appointment.Body = Range("a" & myR) & ", " & Range("b" & myR) & ", " &
Range("c" & myR) &
", " & Range("d" & myR) & ", " & Range("e" & myR)



Appointment.ReminderPlaySound = True
Appointment.Display

'Outlook.quit
'Set Outlook = Nothing
End Sub
'*************************************

To loop on a number of cells:

'*************************************
Private Sub CommandButton1_Click()
Dim Outlook As Object
Dim Appointment As Object
Dim Category As String
Dim Time As Variant
Dim myR As Long

Const Item = 1

Set Outlook = CreateObject("Outlook.Application")

For myR = 2 To Cells(Rows.Count,1).End(xlUp).Row

Set Appointment = Outlook.CreateItem(1)
Time = "08:30AM"

Appointment.Location = Range("a" & myR) & ", " & Range("d" & myR) & ", " &
Range("e" & myR)

Appointment.Subject = Range("i" & myR)

Appointment.Start = DateAdd("d", 350, Range("b" & myR)) & " " & Time

Appointment.Body = Range("a" & myR) & ", " & Range("b" & myR) & ", " &
Range("c" & myR) &
", " & Range("d" & myR) & ", " & Range("e" & myR)



Appointment.ReminderPlaySound = True
Appointment.Display
'Perhaps ????
Appointment.Save
Appointment.Close
Next myR

'Outlook.quit
'Set Outlook = Nothing
End Sub
'*************************************


HTH,
Bernie
MS Excel MVP