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!

 

[Iktishaf]

Provided you don't have record numbers like P002-M001, which would "match" with the record number CP002-M001, you can replace
If Cell.Value = ActiveCell.Value Then
with
if InStr(ActiveCell.Value,Cell.Value)>0 Then

 

[mcallaghan]

This is sending Excel a little mad!

I'm seems like it's repeating a process over and over, and has basically crashed.

 

[mcallaghan]

I'm not sure how that would work anyway. Perhaps I didn't explain properly, or perhaps I don't understand.
The value of the activecell is "CP002-M001, CP-R002, CP004-M003". I want to search for all records that contain any of those IDs. There is one for each, and it should copy the whole row for each.

 

[Iktishaf]

The problem may also be that I cannot visualise the exact nature of your data. What I have done below is to take account of the multiple values stored in the activecell. First, I have separated out the individual codings and placed then in the elements of an array called codes. Then, instead of comparing the activecell with each cell in the range, I have allowed the cell to be compared against the elements held in the array. If a match is found with one of them, the row is copied.

Of course, because you search over multiple columns, it is possible that a match may be found in more than one column of the same row, in which case your program will produce multiple copies of that row. I have not addressed that issue because I don't know the exact structure of your data, and only you will know if this instance will occur.


Sub Find_Related()
Dim i As Integer, no As Integer, x As Integer, Cell As Range, codes() As String, _
s As String, a As Worksheet, b As Worksheet, c As Worksheet
Set a = Sheets("Target Operating Model")
Set b = Sheets("Related Actions")
Set c = Sheets("Risks")
no = 1
s = ActiveCell.Value
If s = "" Then Exit Sub
Do
i = InStr(s, ",")
If i > 0 Then
ReDim Preserve codes(no)
codes(no) = Left$(s, i - 1)
s = Right$(s, Len(s) - i)
If Left$(s, 1) = " " Then s = Right$(s, Len(s) - 1)
no = no + 1
End If
Loop Until i = 0
ReDim Preserve codes(no)
codes(no) = s
x = 1
For Each Cell In a.Range("A1:F1000")
codes(0) = Cell.Value
i = no
Do While Cell.Value = codes(i)
i = i - 1
Loop
If i > 0 Then
x = x + 1
b.Rows(x).Value = Cell.EntireRow.Value
End If
Next
For Each Cell In c.Range("A1:F1000")
codes(0) = Cell.Value
i = no
Do While Cell.Value = codes(i)
i = i - 1
Loop
If i > 0 Then
x = x + 1
b.Rows(x).Value = Cell.EntireRow.Value
End If
Next
ActiveWorkbook.Sheets("Related Actions").Select
End Sub

 

[mcallaghan]

Cool, I thought I'd have to do it using arrays.

Sorry I've been away from the project for a few days.

Now, when I use the code above it whirrs round for about a minute and then returns the error Out of Range on Do While Cell.Value = codes(i). Or it just crashes.

I'm not sure what to do, and I can't follow your code very well myself due to limited understanding. If you can think of why it is doing that, that would be great. Or if you could explain the code to me a little, that might make me able to sort it.

I really appreciate your help on this.

Thanks.

 

[mcallaghan]

OK, I've made a lot of progress, and am almost there, just need a tiny bit of help.
I'm splitting the activecell, and putting the values two columns to the left in an empty column. Then I'm selecting the first of these values using offset. Then I'm using the code I put above to find examples of the activecell. I've tried letting that whole process go and then saying Next Select activecell offset (1,0) and repeating the process but it doesn't work, it just copies the results of the first search. Then I tried making it If activecell Or activecell offset(1,0) but that didn't work either. Any ideas?

Sub Find_Related()
Dim A As Worksheet, b As Worksheet
Dim Z As Long
Dim ArrayValues() As String
Dim StringToProcess As String
Dim Counter As Long
StringToProcess = ActiveCell.Value
ArrayValues() = Split(StringToProcess, ",")
Counter = 1
For Z = LBound(ArrayValues) To UBound(ArrayValues)
ActiveCell.Offset(Counter, -2).Value = ArrayValues(Z)
Counter = Counter + 1
Next
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
ActiveCell.Offset(1, -2).Select
For Each Cell In A.Range("A1:F1000")
If Cell.Value = ActiveCell.Value Or Cell.Value = ActiveCell.Offset(1, 0).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

 

[Iktishaf]

Sorry for the delay in replying. Please revert to the original code but change the two lines that read
Do While Cell.value = codes(i)
to
Do While cell.value <> codes(i)

I inadvertently sent you an earlier (wrong) version. My apologies.

Question:Do all the cells examined in your search contain data, or are most of them empty?

 

[mcallaghan]

Hm, even with this, the process takes a very long time, and the results are incorrect (in a way that I don't see the reasons for) and I'm just not clever enough to understand it. I feel like I'm very close with the other way I've been doing it (above), as I have converted the cells into individual cells containing all the data I need. I just need to go down the row copying data using each of these cells as a search term. Can you think of how to do this?

 

[Iktishaf]

In what way are the results incorrect? Are you copying rows that should not be copied, or are you not copying rows that should be copied, or something else? The answer to this question is very important.