PDA

View Full Version : [SOLVED] trying to create vba to copy data when option button is selected



steve400243
06-24-2017, 10:00 AM
Hello, on the attached worksheet I am looking for VBA to copy and paste to the body of an email - column A thru I, and any rows used, when the option button is clicked. A user would then input the email address to send. We are using outlook.
Then when the transfer to complete option is selected, transfer the data starting in A3 to I3 to the complete tab and auto saving for history. Then clearing all data starting in row 3 on the 1st tab making the worksheet ready for the next user. Also the date and time listed in I1 like the example shown on the complete tab. Thank you in advance for all help.




also posted at - http://www.ozgrid.com/forum/showthread.php?t=204550

steve400243
06-24-2017, 10:54 AM
I was able to get the create email option working with this code:

Option Explicit


Public Const olMailItem = 0


Public Sub Create_Outlook_Email()


Dim lastRow As Long
Dim tempSheet As Worksheet
Dim r As Long, c As Long
Dim HTML As String
Dim OutApp As Object 'Outlook.Application
Dim OutEmail As Object 'Outlook.MailItem

With ActiveSheet

'Filter active sheet on columns A:I where column A is not blank

Application.ScreenUpdating = False
.AutoFilterMode = False
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1:I" & lastRow).AutoFilter Field:=1, Criteria1:="<>"

'Add a temporary sheet and copy filtered rows to it

Set tempSheet = ThisWorkbook.Worksheets.Add
.AutoFilter.Range.Copy tempSheet.Range("A1")
.AutoFilterMode = False
Application.ScreenUpdating = True

End With

'Loop through rows and columns A:I on temporary sheet and construct HTML table

HTML = ""
HTML = HTML & "<br>"
HTML = HTML & "<table border='1' cellspacing='0' cellpadding='5' style='font-family:arial; font-size:10'>" & vbCrLf
HTML = HTML & "<tbody>" & vbCrLf

With tempSheet
'Row 1 - column headings
HTML = HTML & "<tr style='background-color:#0000FF; color:#FFFFFF'>"
For c = 1 To 9
HTML = HTML & "<td>" & .Cells(1, c).Value & "</td>"
Next
HTML = HTML & "</tr>" & vbCrLf

'Rows 2 to end - data rows
For r = 2 To .UsedRange.Rows.Count
HTML = HTML & "<tr>"
For c = 1 To 9
HTML = HTML & "<td>" & .Cells(r, c).Value & "</td>"
Next
HTML = HTML & "</tr>" & vbCrLf
Next
End With

HTML = HTML & "</tbody>" & vbCrLf
HTML = HTML & "</table>" & vbCrLf
HTML = HTML & "<br>"

'Delete the temporary sheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False
tempSheet.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Set OutApp = CreateObject("Outlook.Application") 'New Outlook.Application
Set OutEmail = OutApp.CreateItem(olMailItem)

'Create email with the HTML table and display the email


With OutEmail
'.To = "email.address1@email.com"
'.CC = "email.address2@email.com"
'.Subject = "Email subject"
.HTMLBody = HTML
.Display
End With

Set OutEmail = Nothing
Set OutApp = Nothing

End Sub




now just looking for the transfer when complete option.

Logit
06-24-2017, 12:49 PM
.


Option Explicit



Public Const olMailItem = 0


Public Sub Create_Outlook_Email()


Dim lastRow As Long
Dim tempSheet As Worksheet
Dim r As Long, c As Long
Dim HTML As String
Dim OutApp As Object 'Outlook.Application
Dim OutEmail As Object 'Outlook.MailItem

With ActiveSheet

'Filter active sheet on columns A:I where column A is not blank

Application.ScreenUpdating = False
.AutoFilterMode = False
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1:I" & lastRow).AutoFilter Field:=1, Criteria1:="<>"

'Add a temporary sheet and copy filtered rows to it

Set tempSheet = ThisWorkbook.Worksheets.Add
.AutoFilter.Range.Copy tempSheet.Range("A1")
.AutoFilterMode = False
Application.ScreenUpdating = True

End With

'Loop through rows and columns A:I on temporary sheet and construct HTML table

HTML = ""
HTML = HTML & "<br>"
HTML = HTML & "<table border='1' cellspacing='0' cellpadding='5' style='font-family:arial; font-size:10'>" & vbCrLf
HTML = HTML & "<tbody>" & vbCrLf

With tempSheet
'Row 1 - column headings
HTML = HTML & "<tr style='background-color:#0000FF; color:#FFFFFF'>"
For c = 1 To 9
HTML = HTML & "<td>" & .Cells(1, c).Value & "</td>"
Next
HTML = HTML & "</tr>" & vbCrLf

'Rows 2 to end - data rows
For r = 2 To .UsedRange.Rows.Count
HTML = HTML & "<tr>"
For c = 1 To 9
HTML = HTML & "<td>" & .Cells(r, c).Value & "</td>"
Next
HTML = HTML & "</tr>" & vbCrLf
Next
End With

HTML = HTML & "</tbody>" & vbCrLf
HTML = HTML & "</table>" & vbCrLf
HTML = HTML & "<br>"

'Delete the temporary sheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False
tempSheet.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Set OutApp = CreateObject("Outlook.Application") 'New Outlook.Application
Set OutEmail = OutApp.CreateItem(olMailItem)

'Create email with the HTML table and display the email


With OutEmail
'.To = "email.address1@email.com"
'.CC = "email.address2@email.com"
'.Subject = "Email subject"
.HTMLBody = HTML
.Display
End With

Set OutEmail = Nothing
Set OutApp = Nothing

End Sub


Sub cpyToComplete()


Sheets("Complete").Range("A2:I6").Value = Sheets("FXF CALL IN LOG").Range("A3:I7").Value
Sheets("Complete").Range("J1").Value = Sheets("FXF CALL IN LOG").Range("I1").Value

Sheets("FXF CALL IN LOG").Range("A3:I7").Value = ""


End Sub

steve400243
06-24-2017, 01:22 PM
Thank you logit. I will not have a chance to check it out until Monday morning as I have left my office for the weekend. I will test it then and let you know. I appreciate your time. And the code.

Logit
06-24-2017, 01:49 PM
.
You are welcome.

steve400243
06-26-2017, 06:51 AM
.
You are welcome.

Good Morning Logit, This transfers to log as needed. Forgot to mention that this will be used as the history for the data as it is transferred over. The new data would need to go to the next line down, and auto save each time new data is transferred.

Logit
06-26-2017, 08:40 AM
.
Try this change to the copy macro :



Sub cpyToComplete()

Application.ScreenUpdating = False
Dim CopySheet As Worksheet
Dim PasteSheet As Worksheet


Set CopySheet = Worksheets("FXF CALL IN LOG")
Set PasteSheet = Worksheets("Complete")


PasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).Value = Sheets("FXF CALL IN LOG").Range("J1").Value
CopySheet.Range("A2:I7").Copy
PasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

steve400243
06-26-2017, 08:57 AM
Hello, and thanks for the quick update. I sure it is my lack of knowledge in VBA, but I cant get it to do anything now. Here is the updated file.

Logit
06-26-2017, 09:16 AM
.
Something was corrupted in the workbook. Here is the fixed copy.

steve400243
06-26-2017, 09:31 AM
That did it Logit, Thanks very much, I really appreciate your time, and code.

Logit
06-26-2017, 10:48 AM
You are welcome.