rsutton1981
New Member
- Joined
- Mar 9, 2016
- Messages
- 47
- Office Version
- 365
- Platform
- Windows
I have a sheet called "Risk Selection"; in Column A6 down you select a 'Risk Item', that then brings up the 'risk elements' (Column C). Once selected, hitting the start button the code below then searches for any reference in a sheet called "database" and copies it to the a sheet called "risk assessment". The code for this is below and works perfectly.
It is possible that a 'risk element' may appear several times depending on whether if it appears under different "risk items". for example asbestos is listed under several risk items. What I want to do is copy the 'risk item' name (Column A) and paste it to the "risk assessment" column A with the associated data from the code below.
Where there are multiple copies of the 'risk element' under different 'risk items' I want the code to concatenate the 'risk items' so there are not duplicates in the risk assessment sheet.
It is possible that a 'risk element' may appear several times depending on whether if it appears under different "risk items". for example asbestos is listed under several risk items. What I want to do is copy the 'risk item' name (Column A) and paste it to the "risk assessment" column A with the associated data from the code below.
Where there are multiple copies of the 'risk element' under different 'risk items' I want the code to concatenate the 'risk items' so there are not duplicates in the risk assessment sheet.
VBA Code:
Sub search()
Dim Dic As Object
Dim Cl As Range
Dim wsRA As Worksheet
Set wsRA = Sheets("Risk Assessment")
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Database")
For Each Cl In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
If Not Dic.Exists(Cl.Value) Then
Dic.Add Cl.Value, Cl
Else
Set Dic(Cl.Value) = Union(Cl, Dic(Cl.Value))
End If
Next Cl
End With
With Sheets("Risk Selection")
For Each Cl In .Range("B6", .Range("B" & Rows.Count).End(xlUp))
If Dic.Exists(Cl.Value) Then
Dic(Cl.Value).EntireRow.Copy wsRA.Range("B" & Rows.Count).End(xlUp).Offset(1, -1)
End If
Next Cl
End With
End Sub
