Copied Table Missing First Column

M

Marhier

Board Regular
Joined
Feb 21, 2017
Messages
128
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
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:
Code: 
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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
where do you select your output

Range("E:J,N:W").Select
Selection.EntireColumn.Hidden = True
Application.Goto Reference:="FilterList2"
Selection.CopyPicture
 
Upvote 0
Hi mole999, thanks for coming back to me.
How do you mean - I set the code to copy the selection as a picture, then tell it to open a new email in Lotus notes and paste to the body of that.

My full code is as follows:
Code: 
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
Range("E:J,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
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

'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").Select
Call PR_Protect
Application.ScreenUpdating = True
End Sub

Much appreciated.
Thank you.
 
Last edited:
Upvote 0
Sorry as untested but does not referring to the range directly not work?

Code: 
wsSheet.Range("FilterList2").CopyPicture
 
Upvote 0
It does the same thing unfortunately.
Though I've just ran through the code step by step using F8 (not sure why I hadn't done this earlier), and when it gets to this section:
Code: 
Range("E:J,N:W").Select

For some reason, it's selecting columns A to W instead of what I'm actually telling it to select... Would this have something to do with merged cells above the table?

Thank you.
Regards
Marhier
 
Upvote 0
Would this have something to do with merged cells above the table?
Click to expand...

Almost certainly yes but can't 100% confirm because I don't use them as "merged " and "cells" when combined are nasty words to me.

Btw can you not use Center across selection rather than merged cells?
 
Last edited:
Upvote 0
I can confirm that was most certainly the case, lol; I ran the code with everthing above row 9 unmerged and it worked fine.
Why does vba struggle hiding columns with merged cells - if it can be done manually, and is there any around this?

I guess I can write code to unmerge the cells first and then re-merge them after?
I'd ideally like to keep them merged due to the design of the form I've created.

Any thoughts?
Thanks again.
Regards
Martin
 
Upvote 0
I did try that, 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

Code: 
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!
 
Last edited:
Upvote 0
but if anyone has any ideas how to simpify this, it would be greatly appreciated.
Click to expand...


Well to start with you can remove all those Selects/Selections which must be slowing down your code greatly and as I have already stated you don't need to use Application.Goto to make a change to a named range.

If I haven't missed anything....


Code: 
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
        End If
    End With

    'Unmerge cells above table
    Range("TableHead").UnMerge

    'Hide columns
    Range("E:J,N:W").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").Hidden = False
    wsSheet.AutoFilter.ShowAllData

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

Similar threads

S
  • Solved
Copy hyperlinks from one table column to another. The columns are identical
Replies
2
Views
73
sspatriots
S
P
  • Question
Copy method of worksheet class failed" with pivot table
Replies
4
Views
299
programsam
P
thedm
  • Question
VBA - Pivot table - Excel - copy data on specific column and paste to another template
Replies
1
Views
648
thedm
thedm
willow1985
  • Solved
VBA Compile error - Trying to send an email using VBA/Excel
Replies
6
Views
561
gorgkhan
G
L
  • Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13

Forum statistics

Threads
1,215,239
Messages
6,123,818
Members
449,127
Latest member
Cyko

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