Export only visible rows

[Edd78]

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.

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!

 

[yky]

Try this:

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]

To look at visible rows try

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