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 1^st 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

Originally Posted by Logit

.
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.

Thread: trying to create vba to copy data when option button is selected

Thread Tools

Display

trying to create vba to copy data when option button is selected

Posting Permissions