Copied Table Missing First Column

**Marhier** · 07-24-2018, 06:15 AM

Afternoon all.
Got an issue I can't seem to get 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 M9 and Y1010
A filter is applied to column Y for any text containing "O".
Columns N:W are hidden, leaving only 3 of the columns in the named range visible (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 it.

The issue I'm having:
When I paste the table into Lotus Notes, it's only pasting columns X & Y, leaving out column M.
Though when I copy and paste manually, it works without an issue, giving me all data in the 3 visible columns (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
Columns("N:W").Select
Selection.EntireColumn.Hidden = True
Application.Goto Reference:="FilterList2"
Selection.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

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

**p45cal** · 07-24-2018, 10:27 AM

Doesn't look like you're the only one.
http://lmgtfy.com/?q=excel+paste+picture+cut+off
What version of Excel are you using?

I don't have Lotus, but I tried this and pasted the picture elsewhere and got a very poor picture, but on reducing the size of what I was copying I got a half-decent image, then improved a lot more by choosing the bitmap option.
So try this line instead of the Application.Goto and .CopyPicture lines:

Intersect(Range("FilterList2"), ActiveSheet.AutoFilter.Range).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Otherwise I think it a case of trying a bunch of suggestions in the Google search returns.

**Marhier** · 07-24-2018, 10:37 PM

Good morning p45cal and thanks for coming back to me.
I tried what you said, but it only loads a blank picture, which seems to be the same size as if it were loading the picture without column M again.

I spent a long time on Google yeserday trying to get to the bottom of it.
I shall keep at it.

If you have any other suggestions, it would be greatly appreciated.

I have now also posted this here as this forum has been helpful to me in the past:
https://chandoo.org/forum/threads/co...-column.39243/

Thanks again.
Regards
Marhier.

**Marhier** · 07-30-2018, 10:46 PM

I have also posted this here:
https://www.mrexcel.com/forum/excel-...ml#post5115301

**Marhier** · 07-31-2018, 03:25 AM

So I figured out the issue... It was to do with merged cells above my table.
When it ran the code:

Range("E:J,N:W").Select

it ended up hiding columns A to X, thus leaving me with only two columns to copy.

I would center across selection rather than merge cells, but if you see design of my form, that approach will only work for a small majority of cells in that range.

It's a pain in the butt, but I've made it unmerge the cells in that range first and then re-merge them after

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
    Range("A1").Select
    Call PR_Protect
    Application.ScreenUpdating = True
Exit Sub
Else
End If
End With

'Unmerge cells above table
Application.Goto Reference:="TableHead"
Selection.UnMerge

'Hide columns
Range("E:J,N:W").Select
Selection.EntireColumn.Hidden = True

'Copy selection as picture
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").Select
Selection.EntireColumn.Hidden = False
wsSheet.AutoFilter.ShowAllData
Range("A1").Select

'Re-merge cells above table
Range("A1:D3").Select
Selection.Merge
Range("A4:B5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("A6:B7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("C4:I5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("C6:I7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("J4:L5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("J6:L7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("M4:P5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("M6:P7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("E1:G3").Select
Selection.Merge
Range("H1:H3").Select
Selection.Merge
Range("I1:J3").Select
Selection.Merge
Range("K1:L3").Select
Selection.Merge
Range("M1:M3").Select
Selection.Merge
Range("N1:P3").Select
Selection.Merge
Range("Q1:V1").Select
Selection.Merge
Range("Q2:S2").Select
Selection.Merge
Range("Q3:S3").Select
Selection.Merge
Range("Q4:S4").Select
Selection.Merge
Range("Q5:S5").Select
Selection.Merge
Range("Q6:S6").Select
Selection.Merge
Range("Q7:S7").Select
Selection.Merge
Range("T2:V2").Select
Selection.Merge
Range("T3:V3").Select
Selection.Merge
Range("T4:V4").Select
Selection.Merge
Range("T5:V5").Select
Selection.Merge
Range("T6:V6").Select
Selection.Merge
Range("T7:V7").Select
Selection.Merge
Range("A8:H8").Select
Selection.Merge
Range("J8:U8").Select
Selection.Merge

'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").Select
Selection.EntireColumn.Hidden = False
wsSheet.AutoFilter.ShowAllData
Range("A1:D3").Select
Selection.Merge
Range("A4:B5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("A6:B7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("C4:I5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("C6:I7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("J4:L5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("J6:L7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("M4:P5").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("M6:P7").Select
Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    End With
Range("E1:G3").Select
Selection.Merge
Range("H1:H3").Select
Selection.Merge
Range("I1:J3").Select
Selection.Merge
Range("K1:L3").Select
Selection.Merge
Range("M1:M3").Select
Selection.Merge
Range("N1:P3").Select
Selection.Merge
Range("Q1:V1").Select
Selection.Merge
Range("Q2:S2").Select
Selection.Merge
Range("Q3:S3").Select
Selection.Merge
Range("Q4:S4").Select
Selection.Merge
Range("Q5:S5").Select
Selection.Merge
Range("Q6:S6").Select
Selection.Merge
Range("Q7:S7").Select
Selection.Merge
Range("T2:V2").Select
Selection.Merge
Range("T3:V3").Select
Selection.Merge
Range("T4:V4").Select
Selection.Merge
Range("T5:V5").Select
Selection.Merge
Range("T6:V6").Select
Selection.Merge
Range("T7:V7").Select
Selection.Merge
Range("A8:H8").Select
Selection.Merge
Range("J8:U8").Select
Selection.Merge
Range("A1").Select
Call PR_Protect
Application.ScreenUpdating = True
End Sub

It works for now, but if anyone has any ideas how to simpify this, it would be greatly appreciated.

Thank you.
Regards
Marhier!

**Marhier** · 08-02-2018, 12:12 AM

After realising the all .Select in the above would be causing my code to run slowly, I figured that might be what was causing the problem in the first place!
From my original code, 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!

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

Lesson learned... Avoid .Select unless absolutely necessary!

Thread: Copied Table Missing First Column

Thread Tools

Display

Copied Table Missing First Column

Posting Permissions