Macro met alleen gefilterde items

[jk87]

Hallo allen,

Ik ben niet erg thuis in VBA maar wil het graag gebruiken om afspraken van Excel naar Outlook te zetten.

Nu heb ik een script gevonden dat werkt, alleen het doet één ding niet wat ik wel graag wil en ik krijg het niet voor elkaar. namelijk als ik in de tabel door middel van de filter knoppen een selectie maakt wil ik dat alleen de geselecteerde items naar Outlook worden gekopieerd en het scriptje zet alles over. Ik kom er niet uit, het is waarschijnlijk een klein iets met de Do Until commando, maar ook met specialcells celltype visible krijg ik het niet voor elkaar. maar dat komt denk ik omdat ik het gewoon niet goed genoeg snap. Dit is het script dat ik heb:

 Sub AddAppointments()
    Set myOutlook = CreateObject("Outlook.Application")

    r = 7
    Do Until Trim(Cells(r, 1).Value) = ""
        Set myApt = myOutlook.createitem(1)
        myApt.Subject = Cells(r, 4).Value
        myApt.Start = Cells(r, 2).Value
        myApt.Duration = "15"
        myApt.ReminderSet = "15"
        myApt.Body = Cells(r, 6).Value
        myApt.Save
        r = r + 1
     Loop
End Sub

Alvast bedankt voor jullie hulp!

 

[snb]

Sub M_snb()
  with activesheet
     .cells(7,1).currentregion.copy .cells(1,100)
     sn=.cells(1,100).currentregion
     .cells(1,100).currentregion.clearcontents
  end with

  with CreateObject("Outlook.Application")
    for j=2 to ubound(sn)
      with .createitem(1)
        .Subject = Cells(j, 4).Value
        .Start = Cells(j, 2).Value
        .Duration = "15"
        .ReminderSet = "15"
        .Body = Cells(j, 6).Value
        .Save
      end with
    next
  end with
End Sub

 

[jk87]

Hallo Snb,

Bedankt voor je snelle reactie, op de een of andere manier staat de celinstelling nu niet meer goed. De waarden die in mijn originele script onder r staan en welke jij bij j hebt gezet, deze cellen vindt hij nu niet meer. En ik krijg een foutmelding 440.

In de bijlage het bestand, misschien dat het dan duidelijker wordt.

Bedankt voor je hulp!

 

[jk87]

Hallo snb,

Volgens mij ben ik eruit. ik heb de

for j=2 to ubound(sn)

op j=7 gezet en nu pakt hij wel de goede.

Super bedankt, hier gaan we veel voordeel van krijgen!!

 

[snb]

het kan ook zo:

Sub M_snb()
  With ActiveSheet
     .ListObjects(1).DataBodyRange.Copy .Cells(1, 100)
     sn = .Cells(1, 100).CurrentRegion
     .Cells(1, 100).CurrentRegion.ClearContents
  End With

  With CreateObject("Outlook.Application")
    For j = 1 To UBound(sn)
      With .createitem(1)
        .Subject = Cells(j, 4).Value
        .Start = Cells(j, 2).Value
        .Duration = "15"
        .ReminderSet = "15"
        .Body = Cells(j, 6).Value
        .Save
      End With
    Next
  End With
End Sub

NB. Het weeknummer in de tabel is fout: gebruik weeknum(.... ; 21)

 

[jk87]

Excuus ik was iets te vroeg met juichen, hij selecteert nu nog steeds alle regels en niet alleen de geselecteerde. Ik dacht dat hij dit eerst wel deed, maar nu in ieder geval niet en ik heb niets aan de code verandert. Wel wat celopmaken en validatieregels toegevoegd maar dat zou het niet mogen zijn toch?

 

[jk87]

Ik krijg bij beide scripts een foutmelding bij

        .Start = Cells(j, 2).Value

Weet jij waar dit aan ligt?