Find and copy corresponding value to another cell on another sheet

[AMarchetti]

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

 

[JLGWhiz]

Is the object in red font supposed to be a variable? I don't see it declared nor defined anywhere. Maybe a period is missing.

If Not ARng Is Nothing Then
FirstAddress = [COLOR="#B22222"]ARngAddress[/COLOR]
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 [COLOR="#B22222"]ARngAddress[/COLOR] <> FirstAddress
End If

 

[AMarchetti]

Yes, it should be ARng.Address.

 

[JLGWhiz]

I have looked this over pretty good and cannot find any furry hands in the code, other than the nits I have previously mentioned. I did not try to set up test files on it, but you can use the F8 function key while the vbEditor is open to walk through the code line by line and see what it is doing and specifically where it errors. When it errors, hover the mouse pointer over your variables to see if the tool tips shows the values that you expect the variables to hold at that point. That is how I isolate the problems when I have similar conditions in my code.

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 = ARng.Address
                    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 ARng.Address <> 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

 

[AMarchetti]

Yes, the code I have works, my problem is when I modify my code as per below:
It searches for all the words and pastes the corresponding value to the new sheet, but if it finds more than one word, it doesn't add the values. I have modified the code lower down where I can get it to add the values if more than one word is found, but then it gives an error when there is only one word found in the sheet and ends before moving on to the next word (Object variable or With block variable not set).

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 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
    WorArr = Array("Administration", "Installation", "Internet Connection", "Mobile Device", "Network", "Printer", "Reports", "3rd Party Software", "Email", "File or Folders", "Scanning", "Terminal Servers", "Server", "Software", "Workstation")
    
    Set NewSh = Sheets("Charts")


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


    With Sheets("ServiceType_SubType_Item_byComp").Range("D:F")
    
        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
                    
                        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
            
            Set rngFound = .FindNext(rngFound)
            End If
        Next Wor




    End With


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


End Sub

If I move Set rngFound = .FindNext before the Loop instead of after, I get an error for the find value if there is only one instance found, otherwise it works and adds the values if more than one instance is found.

                        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
                    
                    Set rngFound = .FindNext(rngFound)
                        
                Loop Until rngFound.Address = FirstAddress

 

[JLGWhiz]

try it with your FindNext statement inside the Do loop and add the If Then statement as shown below.

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

 

[AMarchetti]

Thank you so much. Almost there, but get an error on the

Set rngFound = .FindNext(rngFound)

after the End With (Object variable or With block variable not set). If I move it below the Loop then it runs without error, but obviously doesn't add the duplicate values. Again, many thanks for the assistance.

 

[JLGWhiz]

If you put the FindNext statement outside the loop, then your Loop Until statement is useless because the Loop Until statement evaluates the FindNext results. That is why I added the If Then statement to handle the single occurence of your newRng variable.

 

[AMarchetti]

I do understand that, but with your code as is I get a Object variable or With block variable not set error?

 

[AMarchetti]

Sorry, I get the above erro when it moves to the Loop statement as the rngFound.Address returns as "Object variable or With block variable not set".