Move outlook contacts to folder

[XLSM Belgium]

Hi all,

I have my icloud account linked to my outlook, and all contacts are added to a folder called "contacts"
I can then manually add folders to sort contactitems.
However, when you "move" a contact from the main group to a different folder, it also stays in the main group.
Therefor the main group "Contacts" is a representation of all available contacts in icloud, no matter what subfolder they are assigned to.

I would like to have a separate folder called "Ungrouped", into which all contacts which aren not yet assigned to a group, will be listed.

I wrote this sub:

Sub testicloud()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olitems As Outlook.Items
    Dim olContact As Outlook.ContactItem
    Dim olIcloud As Outlook.MAPIFolder
    Dim olIcloudKlanten As Outlook.MAPIFolder
    Dim olIcloudUngrouped As Outlook.MAPIFolder
    
    Dim obj1 As Object, obj2 As Object
    Dim fol As Outlook.MAPIFolder
    Dim i As Integer
    
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olIcloud = olNS.Folders("iCloud").Folders("Contacts")
    Set olIcloudUngrouped = olIcloud.Folders("Ungrouped")
    
    For Each obj1 In olIcloud.Items
        For Each fol In olIcloud.Folders
            For Each obj2 In fol.Items
                If obj1 = obj2 Then GoTo found
            Next obj2
        Next fol
        
        'contact is not added to any folder, adding it to "ungrouped"
        Debug.Print "Adding", obj1.FullName
        obj1.move (olIcloudUngrouped)
found:
    Next obj1
End Sub

there are 2 problems with this:
-While it works for finding the ungrouped contactitems, it is very slow.
-the actual moving of the contact does not work. I get an error: "Type mismatch"

 

[XLSM Belgium]

problem 2 is solved:

first of all, I needed to remove the brackets surrounding olIcloudUngrouped

obj1.move olIcloudUngrouped

This allowed the code to move on, but did NOT move the contact.
I suppose this has to do with the fact that it also had to remain in the original folder.
Copying was also not an option, because then I ended up with a duplicate contact in the original folder.

The solution for me is to move the contact out of the icloud root, into the default contacts folder.
Afterwards, I move the contact back to the icloud "ungrouped" folder, which is where it needed to go in the first place.

Do While tempfol.items.Count > 0
    tempfol.items(1).Move Ungrouped
Loop

So, everything works (with a small detour, but working nonetheless).
Still the problem remains that this is a very slow process.
To loop through my 125 contacts, takes around 75 seconds!!!

If anyone has any idea on how to speed this up?