Copied Table Missing First Column

[Marhier]

Good morning.

First of all, I'd like to mention I have also posted this issue here:
https://chandoo.org/forum/threads/copied-table-missing-first-column.39243/
http://www.vbaexpress.com/forum/showthread.php?63260-Copied-Table-Missing-First-Column

I've got an issue I can't seem to wrap my head around and hoping someone could offer some advice.

What I'm trying to achieve:
I have a named range called "FilterList2", which spans over cells A9 and Y1010
A filter is applied to column Y for cells containing the text "O".
Columns E:J and N:W are hidden, leaving only 9 of the columns in the named range visible (A to D, K to M, X & Y).
Named range "FilterList2" is selected.
Selection copied as a picture.
A new email is created in Lotus Notes and that picture is pasted into the body of the email.

The issue I'm having:
When I paste the table into Lotus Notes, it's only pasting columns X & Y, leaving out columns A to D and K to M.
Though when I copy and paste manually, it works without an issue, giving me all data in the visible columns (A to D, K to M, X & Y).

I've tried writing the code so that it copies the selection's visible data, but the same issue persists.

My current code is as follows:

With rRng
  .AutoFilter Field:=25, Criteria1:="O"
  If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then
  MsgBox "There are no off hire lines set as 'To Order' - Status 'O'."
  wsSheet.AutoFilter.ShowAllData
  Range("A1").Select
  Call PR_Protect
  Application.ScreenUpdating = True
Exit Sub
Else
End If
End With
[B]Range("E:J,N:W").Select
Selection.EntireColumn.Hidden = True
Application.Goto Reference:="FilterList2"
Selection.CopyPicture[/B]

'Open Lotus Notes & Get Database
Set Notes = CreateObject("Notes.NotesSession")
UserName = Notes.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, _
  (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set db = Notes.GETDATABASE(vbNullString, MailDbName)

'Create & Open New Document
Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.COMPOSEDOCUMENT(, , "Memo")
Set UIdoc = WorkSpace.CURRENTDOCUMENT

'Add Picture & text
Call UIdoc.gotofield("Body")
Call UIdoc.FieldSetText("EnterSendTo", EmailAddress)
Call UIdoc.FieldSetText("EnterCopyTo", ccEmailAddress)
Call UIdoc.FieldSetText("Subject", OffHireSubject)
Call UIdoc.INSERTTEXT(WorksheetFunction.Substitute( _
  "Hello@@The following off hires have been requested on the plant register:@@", _
  "@", vbCrLf))
[B]Call UIdoc.Paste[/B]

Any help would be greatly appreciated.
Thank you.
Regards
Marhier

 

[Marhier]

Ah, ok that makes sense and after making those changes, it's noticalby quicker.
Thanks for your help with this, MARK858.

Regards
Marhier.

 

[Marhier]

...remove all those Selects/Selections which must be slowing down your code greatly...

Hi MARK858.
So after reading what you said, I figured maybe the .Select I'd been doing in my original code might be the problem, so I changed this:

Range("E:J,N:W").Select
Selection.EntireColumn.Hidden = True
Application.Goto Reference:="FilterList2"
Selection.CopyPicture

To:

Range("E:J,N:W").EntireColumn.Hidden = True
wsSheet.Range("FilterList2").CopyPicture

And it worked a treat!
So I now don't need to go through the hassle of unmerging and remerging cells! :D

So my full code is now:

Sub NotifyOffHires()
Application.ScreenUpdating = False
On Error GoTo Errormessage
Dim wsSheet As Worksheet, rRng As Range
Set wsSheet = ActiveSheet
Set rRng = wsSheet.Range("PlantReqTable")
Dim Notes As Object, db As Object, WorkSpace As Object
Dim UIdoc As Object, UserName As String, MailDbName As String
Dim AttachMe As Object, EmbedObj As Object

'Set email addresses
EmailAddress = Range("BuyerEmail").Value
ccEmailAddress = Range("ccBuyer1").Value '& "; " & Range("ccBuyer2").Value

'Set email subject
OffHireSubject = Range("OffHireSubject").Value

'Unprotect sheet
Call PR_UnProtect

'Filter column Y by "O" and copy the selection as a picture
With rRng
    .AutoFilter Field:=25, Criteria1:="O"
    If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then
    MsgBox "There are no off hire lines set as 'To Order' - Status 'O'."
    wsSheet.AutoFilter.ShowAllData
    Call PR_Protect
    Application.ScreenUpdating = True
Exit Sub
Else
End If
End With
Range("E:J,N:W").EntireColumn.Hidden = True
wsSheet.Range("FilterList2").CopyPicture

'Open Lotus Notes & Get Database
Set Notes = CreateObject("Notes.NotesSession")
UserName = Notes.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, _
    (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set db = Notes.GETDATABASE(vbNullString, MailDbName)

'Create & Open New Document
Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.COMPOSEDOCUMENT(, , "Memo")
Set UIdoc = WorkSpace.CURRENTDOCUMENT

'Add Picture & text
Call UIdoc.gotofield("Body")
Call UIdoc.FieldSetText("EnterSendTo", EmailAddress)
Call UIdoc.FieldSetText("EnterCopyTo", ccEmailAddress)
Call UIdoc.FieldSetText("Subject", OffHireSubject)
Call UIdoc.INSERTTEXT(WorksheetFunction.Substitute( _
    "Hello@@The following off hires have been requested on the plant register:@@", _
    "@", vbCrLf))
Call UIdoc.Paste
Call UIdoc.INSERTTEXT(Application.Substitute( _
    "@@Thank you@@", "@", vbCrLf))

'Unfilter active sheet
Columns("D:X").Hidden = False
wsSheet.AutoFilter.ShowAllData

'Protect Sheet
Call PR_Protect
Application.ScreenUpdating = True
Exit Sub

'Error handler
Errormessage:
MsgBox "Is Lotus Notes running, and have you put email addresses in the required fields?"
Columns("D:X").Hidden = False
wsSheet.AutoFilter.ShowAllData
Call PR_Protect
Application.ScreenUpdating = True
End Sub

So lesson learned... Avoid .Select unless absolutely necessary!