Copy and cut from sheet 'Raised'

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,259
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

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
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

A
  • Question Question
Save as dialogue box for excel, but pre populating filename from source word document
Replies
8
Views
282
RoryA
RoryA
C
  • Solved
VBA Too Slow
Replies
1
Views
314
Cubist
Cubist
P
  • Solved
Email error on border code
Replies
5
Views
370
Patriot2879
P
J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
273
rlv01
R
F
  • Solved
Looping code sequence
Replies
5
Views
431
FrenchCelt
F

Forum statistics

Threads
1,224,813
Messages
6,181,107
Members
453,021
Latest member
Justyna P

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