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]

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".

I believe you will need to post a link to your worksheet to get this resolved. I am having difficulty following the multiple find statements withe both range references and array references.

 

[AMarchetti]

Hi, please find attached my file. The code in question is located in Module3. Please let me know if you need any further information.

https://dl.dropboxusercontent.com/u/65541667/Service Desk Reports_v2 (Autosaved).xlsm

 

[JLGWhiz]

Hi, please find attached my file. The code in question is located in Module3. Please let me know if you need any further information.

https://dl.dropboxusercontent.com/u/65541667/Service Desk Reports_v2 (Autosaved).xlsm

That solves the mystery. The problem is the merged cells. Excel and VBA have a conflict with merged cells and Offset values. This one goes beyond my expertise. Sorry.
Regards, JLG

 

[AMarchetti]

Thank you so much for your assistance. I just added a script to unmerge the cells and it works perfectly. I wouldn't have figured that out without you. Thanks again.

 

[JLGWhiz]

You are welcome. Was not sure if you had to leave the cells merged, but you figured it out, so all is well.
Regards, JLG