Have macro select range but exclude empty columns

Closed
Pluggie Posts 11 Registration date Monday March 11, 2013 Status Member Last seen August 14, 2013 - Jun 7, 2013 at 05:30 AM
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 - Jun 10, 2013 at 12:16 PM
Hello,

I have a worksheet in which a range gets copied and pasted into an email
using a RangeToHTML function from Ron de Bruin's website:
https://www.rondebruin.nl/win/s1/outlook/mail.htm

There's just one little thing I would like to add to the functionality.
I would like the macro that makes the selection, to exclude those columns that have no data. So if a user fills out the sheet with records and for some reason leaves one of the columns in the sheet empty for every record, that column should not be copied to the email.
If there are more than 1 records and in at least one of them a column has a value <> "" the column should be considered for copy.

Does anyone have any idea how I should put that together?

Here is my code that makes the selection and the email (I left out the RangetoHTML function):
Sub Mail_Selection_Outlook_Body()
    ActiveSheet.Unprotect ""
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Make the selection
    LastRow = Range("A65536").End(xlUp).Row
    
    'Set borders on selection
    Range("A2:J" & LastRow).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
 
        With Selection.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    
    'Create email and copy selection to RangetoHTML
    Range("A2:J" & LastRow + 1).Select
    Set rng = Selection
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Deze selectie  bestaat niet of je sheet is beschermd met een wachtwoord" & _
               vbNewLine & "Corrigeer eerst en probeer het dan opnieuw.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "emailadress"
        .CC = ""
        .BCC = ""
        .Subject = "Nieuwe artikelen toevoegen en listen"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    'Clear borders, clear contents and save
    ActiveSheet.Activate
    If MsgBox("Wil je deze artikelen nu uit de spreadsheet verwijderen?" & vbNewLine & "Na verwijdering wordt de spreadsheet opgeslagen en gesloten", vbOKCancel) = vbCancel Then
       ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
       Exit Sub
    End If
    ActiveSheet.Range("A2:J" & LastRow + 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
 
        With Selection.Borders
            .LineStyle = xlNone
        End With
        ActiveSheet.Range("A3:J" & LastRow).Select
        Selection.ClearContents
        Range("A3").Select
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        ActiveWorkbook.Close savechanges:=True
End Sub


Thanks in advance for your answer!
Related:

1 response

TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Jun 10, 2013 at 12:16 PM
Hi Pluggie,

Seems to me that the function RangetoHTML needs a single range. Removing a column from your range would leave you with 2 ranges.

Maybe it's an idea to cut away empty columns, run the code, and paste the columns back in or reload your file.

Those actions could also be put in the code you are using.

Met vriendelijke groet,
Trowa