Copy if contains Activecell componenet

[mcallaghan]

Hi Guys,

I have a doc with various different sheets with records that all have an individual ID. These all relate to a central sheet "Actions" that has records that relate to one or more of the records in the other sheets through a Column G that's called "relating to ID".

What I want is to select a cell in column G and click on a macro to copy out all the records recorded in that ID.

I've got it to work if there is only one ID in the related to column with code like this:

Sub Find_Related()
Dim a As Worksheet, b As Worksheet

Set a = Sheets("Target Operating Model")
Set b = Sheets("Related Actions")
Set c = Sheets("Risks")
Dim x As Integer
Dim Cell As Range
x = 1
For Each Cell In a.Range("A1:F1000")
If Cell.Value = ActiveCell.Value Then
x = x + 1
b.Rows(x).Value = Cell.EntireRow.Value
End If
Next
For Each Cell In c.Range("A1:F1000")
If Cell.Value = ActiveCell.Value Then
x = x + 1
b.Rows(x).Value = Cell.EntireRow.Value
End If
Next

ActiveWorkbook.Sheets("Related Actions").Select
End Sub


I'm happy with this code, but the problem is when the ActiveCell is not "CP002-M001", referencing a single record, but something like "CP002-M001, CP-R002, CP004-M003". I'd like it to copy the records
CP002-M001
CP-R002
CP004-M003
Into three separate rows on the new sheet "Related Actions"

Any ideas how? This is giving me a headache!

 

[mcallaghan]

It was both of those things!
I've just made a breakthrough though, there were spaces between the items, so I needed to change (",") to (", "). I knew it would be something tiny that I would miss. Now the formula I made makes sense, I just need to work out how to search in multiple sheets at once, I'd like something like
For Each Cell In A.Range("A1:F1000") And c.Range("A1:F1000"), but that doesn't work. my lates code looks like this:

Sub Find_Related()
Dim a As Worksheet, b As Worksheet, c As Worksheet, d As Worksheet, e As Worksheet, f As Worksheet, g As Worksheet
Dim Z As Long
Dim ArrayValues() As String
Dim StringToProcess As String
Dim y As Long
StringToProcess = ActiveCell.Value
ArrayValues() = Split(StringToProcess, ", ")
y = 1
For Z = LBound(ArrayValues) To UBound(ArrayValues)
ActiveCell.Offset(y, -2).Value = ArrayValues(Z)
y = y + 1
Next

Set a = Sheets("Related Actions")
Set b = Sheets("Category Management")
Set c = Sheets("Target Operating Model")
Set d = Sheets("Project Management")
Set e = Sheets("Risks")
Set f = Sheets("Issues")
Set g = Sheets("Opportunities")
Dim x As Integer
Dim Cell As Range
x = 1
ActiveCell.Offset(1, -2).Select
If Not IsEmpty(ActiveCell.Value) Then
For Each Cell In c.Range("A1:A1000")
If Cell.Value = ActiveCell.Value Then
x = x + 1
a.Rows(x).Value = Cell.EntireRow.Value
ActiveCell.Offset(1, 0).Select
End If
Next
Columns("E:E").Select
Selection.ClearContents
ActiveWorkbook.Sheets("Related Actions").Select
End If
End Sub


Any Ideas?