Try the macro below. It'll prompt you to choose the destination Calendar,
and use the default Calendar as the source for items to copy from. Change
the "Test" comparison string to look for a Category of your choice.
Sub CopyAppointmentsByCategoryToSharedCalendar()
Dim objMyCal As Outlook.MAPIFolder, objDestCal As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.AppointmentItem, objNewItem As
Outlook.AppointmentItem
Set objNS = Application.GetNamespace("MAPI")
Set objMyCal = objNS.GetDefaultFolder(olFolderCalendar) 'Get default
Calendar folder
'Select Destination Calendar to copy appointments to
Set objDestCal = objNS.PickFolder
If objDestCal.DefaultItemType <> olAppointmentItem Then
MsgBox "You must choose a Calendar folder.", vbOKOnly +
vbExclamation, "Invalid Folder"
Exit Sub
End If
For Each objItem In objMyCal.Items
If InStr(objItem.Categories, "Test") > 0 Then
Set objNewItem = objItem.Copy
objNewItem.Move objDestCal
End If
Next
Set objMyCal = Nothing
Set objDestCal = Nothing
Set objNS = Nothing
Set objItem = Nothing
Set objNewItem = Nothing
End Sub