Find and copy corresponding value to another cell on another sheet

Hi, I need assistance with my code as I am struggling to find a solution. I eventually split the array in two as I was getting an error. I am searching for words in sheet "ServiceType_SubType_Item_byComp" and copying the offset value to sheet "Charts", but often there are two cells with the same name. With the WorArr I have below, if there is only one occurrence then it gives an error, so will only work if there are two cells with the same name. Please assist to simplify the below to search for the name, copy the offset value and if the value is only found once then move on to the next name. If a second occurrence is found, then add the values together.

Sub Update_ServiceTypes()
    
    Dim NewSh As Worksheet, NewRng As Range
    Dim FirstAddress As String
    Dim rngSearch As Range, rngLast As Range, rngFound As Range
    Dim AArr As Variant, ARng As Range, A As Long
    Dim WorArr As Variant, WorRng As Variant, Wor As Long
        
    With Application
        .CutCopyMode = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Search for a Value Or Values in a range
    AArr = Array("Administration", "Installation", "Internet Connection", "Mobile Device", "Network", "Printer", "Reports", "3rd Party Software", "Email", "File or Folders", "Scanning", "Terminal Servers")
    WorArr = Array("Server", "Software", "Workstation")
    
    Set NewSh = Sheets("Charts")

    NewSh.Range("R:R").ClearContents

    With Sheets("ServiceType_SubType_Item_byComp").Range("D:F")
    
        For A = LBound(AArr) To UBound(AArr)

            'If you want to find a part of the rng.value then use xlPart
            'if you use LookIn:=xlValues it will also work with a
            'formula cell that evaluates to "AArr" and "Barr"

            Set ARng = .Find(What:=AArr(A), MatchCase:=False)

            If Not ARng Is Nothing Then
                FirstAddress = ARngAddress
                Do
                
                    'Copy value from the cell in the column to the right if "AArr" or "BArr" is found
                    ARng.Offset(0, 2).Copy
                    Set ARng = .FindNext(ARng)
                        With Sheets("Charts").Range("Q:Q")
                            Set NewRng = .Find(What:=AArr(A), MatchCase:=False)
                            NewRng.Offset(0, 1).PasteSpecial xlPasteValues
                        End With
                    
                    Set NewRng = .FindNext(NewRng)
                Loop While Not ARng Is Nothing And ARngAddress <> FirstAddress
            End If
        Next A
        

        For Wor = LBound(WorArr) To UBound(WorArr)

            Set rngFound = .Find(What:=WorArr(Wor), SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)


            If Not rngFound Is Nothing Then
                FirstAddress = rngFound.Address
                Do
                
                    rngFound.Offset(0, 2).Copy
                    Set rngFound = .FindNext(rngFound)
                    
                        With Sheets("Charts").Range("Q:Q")
                            Set NewRng = .Find(What:=WorArr(Wor), MatchCase:=False)
                            NewRng.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
                        End With
                        
                Loop Until rngFound.Address = FirstAddress
            End If
        Next Wor


    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub