Export only visible rows

Edd78

Board Regular
Joined
Nov 22, 2013
Messages
57
Hi all,

Need some help on a piece of code to export only the visible rows in a worksheet.

I have a worksheet with a list of work items/processes. These are all hidden. After clicking on a button a userform appears where processes can be selected. After submitting the userform all the rows, corresponding with the selected criteria from the userform, are made visible.

By clicking on another button the visible rows need to be exported to outlook as appointments.

The current script copies all the rows instead of only the visible ones and I'm not sure how to edit the script to do so.

Code:
Sub ListSelection()
   
   Sheets("List").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    
    i = 2
    
    Do Until Trim(Cells(i, 1).Value) = ""
        
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
    
        .Start = Cells(i, 3) + Cells(i, 4)     '+ TimeValue("9:00:00")
        .End = Cells(i, 5) + Cells(i, 6)       '+TimeValue("10:00:00")
        .Subject = Cells(i, 1)
        .Location = Cells(i, 2)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 7)
        .ReminderSet = True
        '.Categories = Cells(i, 4)
        .Save
    
    End With
                 
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

Thanks for any help!
 

Some videos you may like

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,812
Office Version
  1. 2010
Platform
  1. Windows
Try this:

Code:
Sub ListSelection()
   
   Sheets("List").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    
    i = 2
    
    Do Until Trim(Cells(i, 1).Value) = ""
        
[COLOR=#ff0000]     If Cells(i,3).ColumnWidth<>0 Then[/COLOR]

    Set olAppt = CalFolder.Items.Add(olAppointmentItem)

    With olAppt
    
        .Start = Cells(i, 3) + Cells(i, 4)     '+ TimeValue("9:00:00")
        .End = Cells(i, 5) + Cells(i, 6)       '+TimeValue("10:00:00")
        .Subject = Cells(i, 1)
        .Location = Cells(i, 2)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 7)
        .ReminderSet = True
        '.Categories = Cells(i, 4)
        .Save
    
    End With

 [COLOR=#ff0000]   End If[/COLOR]
                 
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,898
Office Version
  1. 365
Platform
  1. Windows
To look at visible rows try
Code:
Sub ListSelection()
   
   Sheets("List").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    
    i = 2
    
    Do Until Trim(Cells(i, 1).Value) = ""
     [COLOR=#ff0000] If Not Rows(i).Hidden Then[/COLOR]
         Set olAppt = CalFolder.Items.Add(olAppointmentItem)
                
         With olAppt
         
             .Start = Cells(i, 3) + Cells(i, 4)     '+ TimeValue("9:00:00")
             .End = Cells(i, 5) + Cells(i, 6)       '+TimeValue("10:00:00")
             .Subject = Cells(i, 1)
             .Location = Cells(i, 2)
             .BusyStatus = olBusy
             .ReminderMinutesBeforeStart = Cells(i, 7)
             .ReminderSet = True
             '.Categories = Cells(i, 4)
             .Save
         
         End With
      [COLOR=#ff0000]End If[/COLOR]
      i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,122,469
Messages
5,596,313
Members
414,052
Latest member
Dual Showman

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
Top