Copy and cut from sheet 'Raised'

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,227
Office Version
  1. 2010
Platform
  1. Windows
Hi good evening, hope you can help me please? i have the code below which works great when i click the command button, it copies the data from sheet 'Raised' and pastes it into the body of the email. But i need it to cut it from sheet 'Raised' and move it into sheet 'Additional Job' can you help me please?
VBA Code: 
Private Sub CommandButton3_Click()
Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"


    
    
Dim aOutlook As Object
Dim aEmail As Object
Dim ulFlags As Integer
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim rngDataToEmail As Range

    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)


 ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED

    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)

    With Sheets("Raised")
        Set rngDataToEmail = .Range("B1:Q" & .Range("B" & Rows.Count).End(xlUp).Row)
    End With

    Sheets("Raised").Select
    Columns("A:R").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    aEmail.HTMLBody = "<html><body><p>Hi</p>" & _
                        "<table border=""1"", cellpadding=""10"", style=background:""0xFFFFFF"" >" & _
                        "<td>" & Me.ComboBox2.Value & "</td>" & _
                        "<td>" & RangetoHTML(rngDataToEmail) & "</td>" & _
                        "</table>" & _
                        "<br><br><br>" & _
                        "<td>Any issues let your FTL know ASAP</td>" & _
                        "<td><p>Many Thanks</td>" & _
                        "<td><p>Complex Team</td>" & _
                        "<td></body></html>"


    aEmail.Recipients.Add (UserForm8.TextBox21.Value)
    aEmail.CC = ""
    aEmail.BCC = ""
    aEmail.Subject = (UserForm1.TextBox8.Value)
    aEmail.Display

    Unload Me


End Sub
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
Patriot2879 said:
Hi good evening, hope you can help me please? i have the code below which works great when i click the command button, it copies the data from sheet 'Raised' and pastes it into the body of the email. But i need it to cut it from sheet 'Raised' and move it into sheet 'Additional Job' can you help me please?
VBA Code: 
Private Sub CommandButton3_Click()
Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"


   
   
Dim aOutlook As Object
Dim aEmail As Object
Dim ulFlags As Integer
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim rngDataToEmail As Range

    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)


 ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED

    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)

    With Sheets("Raised")
        Set rngDataToEmail = .Range("B1:Q" & .Range("B" & Rows.Count).End(xlUp).Row)
    End With

    Sheets("Raised").Select
    Columns("A:R").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
    aEmail.HTMLBody = "<html><body><p>Hi</p>" & _
                        "<table border=""1"", cellpadding=""10"", style=background:""0xFFFFFF"" >" & _
                        "<td>" & Me.ComboBox2.Value & "</td>" & _
                        "<td>" & RangetoHTML(rngDataToEmail) & "</td>" & _
                        "</table>" & _
                        "<br><br><br>" & _
                        "<td>Any issues let your FTL know ASAP</td>" & _
                        "<td><p>Many Thanks</td>" & _
                        "<td><p>Complex Team</td>" & _
                        "<td></body></html>"


    aEmail.Recipients.Add (UserForm8.TextBox21.Value)
    aEmail.CC = ""
    aEmail.BCC = ""
    aEmail.Subject = (UserForm1.TextBox8.Value)
    aEmail.Display

    Unload Me


End Sub
Click to expand...
Hi all good morning, i have tried this code below to cut and paste from sheet 'Raised' then paste into last row of 'Additional Jobs' but it dont do anything, hope you can help please.
VBA Code: 
Private Sub CommandButton3_Click()
Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"


    
    
Dim aOutlook As Object
Dim aEmail As Object
Dim ulFlags As Integer
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim rngDataToEmail As Range

    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)


 ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED

    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)

    With Sheets("Raised")
        Set rngDataToEmail = .Range("B1:Q" & .Range("B" & Rows.Count).End(xlUp).Row)
    End With

    Sheets("Raised").Select
    Columns("A:R").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
        With ThisWorkbook.Sheets("Raised")
    Range("A2:R2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    With ThisWorkbook.Sheets("Additional Job")
    emptyRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
    ActiveSheet.Paste
End With

    aEmail.HTMLBody = "<html><body><p>Hi</p>" & _
                        "<table border=""1"", cellpadding=""10"", style=background:""0xFFFFFF"" >" & _
                        "<td>" & Me.ComboBox2.Value & "</td>" & _
                        "<td>" & RangetoHTML(rngDataToEmail) & "</td>" & _
                        "</table>" & _
                        "<br><br><br>" & _
                        "<td>Any issues let your FTL know ASAP</td>" & _
                        "<td><p>Many Thanks</td>" & _
                        "<td><p>Complex Team</td>" & _
                        "<td></body></html>"


    aEmail.Recipients.Add (UserForm8.TextBox21.Value)
    aEmail.CC = ""
    aEmail.BCC = ""
    aEmail.Subject = (UserForm1.TextBox8.Value)
    aEmail.Display
    
    

    Unload Me

End With

End Sub
 
Upvote 0
Patriot2879 said:
Hi all good morning, i have tried this code below to cut and paste from sheet 'Raised' then paste into last row of 'Additional Jobs' but it dont do anything, hope you can help please.
VBA Code: 
Private Sub CommandButton3_Click()
Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"


   
   
Dim aOutlook As Object
Dim aEmail As Object
Dim ulFlags As Integer
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim rngDataToEmail As Range

    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)


 ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED

    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)

    With Sheets("Raised")
        Set rngDataToEmail = .Range("B1:Q" & .Range("B" & Rows.Count).End(xlUp).Row)
    End With

    Sheets("Raised").Select
    Columns("A:R").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
        With ThisWorkbook.Sheets("Raised")
    Range("A2:R2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    With ThisWorkbook.Sheets("Additional Job")
    emptyRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
    ActiveSheet.Paste
End With

    aEmail.HTMLBody = "<html><body><p>Hi</p>" & _
                        "<table border=""1"", cellpadding=""10"", style=background:""0xFFFFFF"" >" & _
                        "<td>" & Me.ComboBox2.Value & "</td>" & _
                        "<td>" & RangetoHTML(rngDataToEmail) & "</td>" & _
                        "</table>" & _
                        "<br><br><br>" & _
                        "<td>Any issues let your FTL know ASAP</td>" & _
                        "<td><p>Many Thanks</td>" & _
                        "<td><p>Complex Team</td>" & _
                        "<td></body></html>"


    aEmail.Recipients.Add (UserForm8.TextBox21.Value)
    aEmail.CC = ""
    aEmail.BCC = ""
    aEmail.Subject = (UserForm1.TextBox8.Value)
    aEmail.Display
   
   

    Unload Me

End With

End Sub
Click to expand...
HIya i have also tried the code below to copy, clear and paste but this doesnt seem to work either, pelase can you help?
VBA Code: 
    With ThisWorkbook.Sheets("Raised")
    Range("A2:R2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
Range("A2:R" & Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
With ThisWorkbook.Sheets("Additional Job")
    emptyRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
    ActiveSheet.Paste
End With
 
Upvote 0
Try something like this:
VBA Code: 
Sub Test()

Dim wsRaised As Worksheet, wsJob As Worksheet
Dim rngRaised As Range, rngJob As Range
Dim rowLastRaised As Long, rowLastJob As Long

Set wsRaised = ThisWorkbook.Sheets("Raised")
Set wsJob = ThisWorkbook.Sheets("Additional Job")

With wsRaised
    rowLastRaised = .Range("A" & Rows.Count).End(xlUp).Row
    Set rngRaised = .Range("A2:R" & rowLastRaised)
End With

With wsJob
    rowLastJob = .Range("A" & Rows.Count).End(xlUp).Row
    Set rngJob = .Range("A" & rowLastJob + 1)
End With


rngRaised.Copy
rngJob.PasteSpecial Paste:=xlPasteValues
rngJob.PasteSpecial Paste:=xlPasteFormats
' If you want to copy the formulas replace the above 3 line with the next line
' rngRaised.Copy Destination:=rngJob

rngRaised.ClearContents

Application.CutCopyMode = False

End Sub
 
Upvote 0
Solution
Alex Blakenburg said:
Try something like this:
VBA Code: 
Sub Test()

Dim wsRaised As Worksheet, wsJob As Worksheet
Dim rngRaised As Range, rngJob As Range
Dim rowLastRaised As Long, rowLastJob As Long

Set wsRaised = ThisWorkbook.Sheets("Raised")
Set wsJob = ThisWorkbook.Sheets("Additional Job")

With wsRaised
    rowLastRaised = .Range("A" & Rows.Count).End(xlUp).Row
    Set rngRaised = .Range("A2:R" & rowLastRaised)
End With

With wsJob
    rowLastJob = .Range("A" & Rows.Count).End(xlUp).Row
    Set rngJob = .Range("A" & rowLastJob + 1)
End With


rngRaised.Copy
rngJob.PasteSpecial Paste:=xlPasteValues
rngJob.PasteSpecial Paste:=xlPasteFormats
' If you want to copy the formulas replace the above 3 line with the next line
' rngRaised.Copy Destination:=rngJob

rngRaised.ClearContents

Application.CutCopyMode = False

End Sub
Click to expand...
Hi thank you for your help, the code does work by pasting the information from 'Raised' into 'Additional Job' but the email body is empty, it has not copied the data over into the email. Please can you advise?
 
Upvote 0
I am a bit confused. I don't understand how the cut and paste question relates to what it is or isn't doing in relation to the email.
You might want to create a separate thread outlining what the issue is in terms of the emailling the data ie what it is and isn't doing in terms of the email.
 
Upvote 0
Alex Blakenburg said:
I am a bit confused. I don't understand how the cut and paste question relates to what it is or isn't doing in relation to the email.
You might want to create a separate thread outlining what the issue is in terms of the emailling the data ie what it is and isn't doing in terms of the email.
Click to expand...
Hi i put the code in the wrong place it now works perfectly thank you for your help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Email error on border code
Replies
5
Views
187
Patriot2879
P
F
  • Solved
Looping code sequence
Replies
5
Views
154
FrenchCelt
F
K
  • Solved
formating question
Replies
3
Views
76
Micron
M
L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
335
RoryA
RoryA
P
  • Solved
Compile error: method or data member not found
Replies
6
Views
255
Patriot2879
P

Forum statistics

Threads
1,215,069
Messages
6,122,958
Members
449,096
Latest member
Anshu121

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top