VBA Solution to Search Text and Return Desired Result

P

plk0507

New Member
Joined
Dec 15, 2021
Messages
18
Office Version
  1. 365
Platform
  1. Windows
Hi,

First-time poster so I want to say thank you in advance for looking at my issue. Below is a sample from my worksheet that is actually hundreds of thousands of lines long.

I'm looking for a solution to search columns J, K, and L for the values in column Y (column y is actually 5-6 thousand lines long). And if it finds the value, return it to column M, separated by a comma.

I've been using the following formula: =TEXTJOIN(", ", TRUE, IF(COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))

My issue with that formula is it also returns partial matches. For example, look at the result in M3. It returned W269 simply because it's a partial match to W2690. On a file with 900 thousand lines, that partial match could repeat itself a few thousand times, and manually fixing it can take days. My other issue is running that formula can take a couple of hours.

My question is, is there a VBA solution to searching this data that will return the desired result without the partial matches? Thank you for your help, I sincerely appreciate it.



Book1.xlsx
ABCDEFGHIJKLMNOPQRSTUVWXY
1Aircraft TypeTail NumberJCNWCE IDWUCHow MalAction TakenWhen Discovered CodeType Maint CodeCorrective ActionDiscrepancyWCE NarrativeHarnessRDIStart DateStop DateLaborBaseUnits ProducedHow Mal ClassBlock NumberHarness Number
2F016D 8900002171 1515502761 62000799XFBVHF OPS CHK C/WVHF AUDIO HARNESS W1654 PART NUMBER H16DW1654-504,W1644 PART NUMBER H16DW1644-514 AND W1844 PART NUMBER H16DW1844-300 REQUIRE REPLACEMENT.VHF AUDIO HARNESS W1654 PART NUMBER H16DW1654-504,W1644 PART NUMBER H16DW1644-514 AND W1844 PART NUMBER H16DW1844-300 REQUIRE REPLACEMENT.W1644, W1654, W184442799.7142799.752KUNSAN1640W1644
3F016D 9000000783 2035105340 630006FSRRECOUP HOURS FOR: SOLDER NEW WAFER ON TO WIRES TO REPAIR W1812-9154J424. PERFORM CONTINUITY CHECK TO ENSURE PROPER CONNECTIONSREF 1F-16CG-2-00GV-00-2***ADD TIME REQ, REF OP#91438*** NSFE FOUND DURING INSTALL OF HARNESS 16DW2690-501 BROKEN PINS WERE FOUND ON W1812-9154J424 T.O./FIG:REF 1F-16CG-2-00GV-00-2***ADD TIME REQ, REF OP#91438*** NSFE FOUND DURING INSTALL OF HARNESS 16DW2690-501 BROKEN PINS WERE FOUND ON W1812-9154J424 T.O./FIG:REF 1F-16CG-2-00GV-00-2W269, W1812, W2690441814418144.3HILL AFB UT1142W1654
4F016D 9000000783 2034904270 630006FSRSOLDER NEW WAFER ON TO WIRES TO REPAIR W1812-9154J424. PERFORM CONTINUITY CHECK TO ENSURE PROPER CONNECTIONSREF 1F-16CG-2-00GV-00-2NSFE FOUND DURING INSTALL OF HARNESS 16DW2690-501 BROKEN PINS WERE FOUND ON W1812-9154J424 T.O./FIG:REF 1F-16CG-2-00GV-00-2NSFE FOUND DURING INSTALL OF HARNESS 16DW2690-501 BROKEN PINS WERE FOUND ON W1812-9154J424 T.O./FIG:REF 1F-16CG-2-00GV-00-2W269, W1812, W269044179441796HILL AFB UT1142W1844
5F016D 8900002166 1505674072 64000799XDDSEE NEW JCN 161896706 FOR UPDATED JOBCOM 2 RADIO TRANSMITS SQUEAL/TONES WHEN MIC IS KEYED, IF VOLUME KNOB IS PAST 3:00 POSITION. VOLUME ANY LOWER AND COM 2 IS INAUDIABLEJOB CREATED TO ORDER AND REPLACE VHF AUDIO HARNESS W1654 PART NUMBER H16DW1654-504,W1644 PART NUMBER H16DW1644-514 AND W1844 PART NUMBER H16DW1844-300.W1644, W1654, W184442563.2542563.292KUNSAN1640W269
6F016D 8800000170 2108891708 69B9870RBBW2690-204-20 R2 IAW 1F-16CG-2-00GV-00-2 SECTION 14PANEL 3434 & 3436 REMOVED TO FOM SEE JCN 210550032001W2690-204-20 SHOOTS OPEN FROM RPS 2382P2/1 TO LVT 2382P12W269, W26902382P12, 2382P2/144286.7144286.731EGLIN AFB FL1140W1812
7F016D 8800000170 21067022814 69B98308RBBFILL PORT HARNESS R2 IAW 1F-16CG-2-00GV-00-2 PARA 14.7MIDS 006,012,029,031,035,056,074,075 MFL'S. TACAN WORKED FINEH16DW2693P4/1 REMOVED FOR REPLACEMENTW269, W269344279.7944280.1324EGLIN AFB FL1140W2690
8F016D 8900002162 21063012810 69B00800SFBREINSTALLED CABLE H16DW2682-600 IAW (PARA 14.8 00GV-2)GUN REQ REM FOR JAMREMOVED CABLE H16DW2682-600 TO FOMW268, W268244263.6744263.712HOLLOMAN1642W268
9F016D 9000000783 2035105370 69000800SSRRECOUP HOURS FOR: INSTALL WIRE HARNESS 16DW2690-501 IN GUN DRUM IAW 16D40730.DOCUMENT STEPS AND TIME OF EACH STEP ON ATTACHED 959***ADD TIME REQ, REF OP#91427*** NSFE WIRE HARNESS 16DW2690-501 FOUND UNINSTALLED. T.O./FIG:IAW 16D40730***ADD TIME REQ, REF OP#91427*** NSFE WIRE HARNESS 16DW2690-501 FOUND UNINSTALLED. T.O./FIG:IAW 16D40730W269, W269044181441812.1HILL AFB UT1642W2682
10F016D 9000000783 2034904290 69000800SSRINSTALL WIRE HARNESS 16DW2690-501 IN GUN DRUM IAW 16D40730.DOCUMENT STEPS AND TIME OF EACH STEP ON ATTACHED 959NSFE WIRE HARNESS 16DW2690-501 FOUND UNINSTALLED. T.O./FIG:IAW 16D40730NSFE WIRE HARNESS 16DW2690-501 FOUND UNINSTALLED. T.O./FIG:IAW 16D40730W269, W269044179441794HILL AFB UT1642
11F016D 8900002167 2007221673 69B0020RFBR2 HARNESS IAW 1F-16CG-2-00GV-00-2 CHAPTER 14238282 P1/4 SMASHED, REQUIRES REPLACEMENTW2690-; 2382P3/3 & 2382P6 INNER WIRE EXPOSED REQUIRE REPLCMENT; 2382P2/1 MISSING GRNDING FSTNER AND 2382P3/3 WORN GRNDING FSTNER NUT REMAIN LOOSE AFTER TIGHTENING PN(H16DW2690-501)W269, W26902382P3/3, 2382P2/1, 2382P643909.543909.8324TULSA1142
Sheet2
 
Sort by date Sort by votes
Here's another one. It may be faster depending on how large your data set is.
VBA Code: 
Sub Harness_Search()

'=TEXTJOIN(", ", TRUE, IF( COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))
Dim input_data() As Variant, X As Long, Y As Long, output() As String, _
harness_numbers() As Variant, Z As Long, Harness_CLCTN As Collection, value() As String

With ThisWorkbook.ActiveSheet

    input_data = .Range(.Range("J2"), .Range("L" & .UsedRange.Rows.Count)).Value2
    harness_numbers = .Range(.Range("Y2"),  .Range("Y" & .UsedRange.Rows.Count)).Value2
End With

Const delimiter As String = ", "

ReDim output(LBound(input_data, 1) To UBound(input_data, 1), 1 To 1)

For X = LBound(input_data, 1) To UBound(input_data, 1)

    Set Harness_CLCTN = New Collection
   
    With Harness_CLCTN
   
        For Y = LBound(input_data, 2) To UBound(input_data, 2)
       
            If Not input_data(X, Y) = Empty Then
           
                For Z = LBound(harness_numbers, 1) To UBound(harness_numbers, 1)
                    'patterns:
                    'code and any non-alphanumeric character + *
                    'code at the end of string
                    'code followed by a space and any number of characters
                    If Not harness_numbers(Z, 1) = Empty _
                    And (input_data(X, Y) Like "*" & harness_numbers(Z, 1) & "[!A-Za-z0-9]*" _
                    Or input_data(X, Y) Like "*" & harness_numbers(Z, 1)) Then
                       
                        On Error Resume Next
                        .Add harness_numbers(Z, 1), harness_numbers(Z, 1)
                   
                    End If
                   
                Next Z
               
            End If
        Next Y
       
        If .Count > 0 Then
            ReDim value(1 To .Count)
            For Z = 1 To .Count
                value(Z) = .Item(Z)
            Next Z
            output(X, 1) = Join(value, delimiter)
        End If
   
    End With
   
Next X

With ThisWorkbook.ActiveSheet
    .Range(.Range("M2"), .Range("M" & .UsedRange.Rows.Count)).Value2 = output
End With

End Sub
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
MoshiM said:
Here's another one. It may be faster depending on how large your data set is.
VBA Code: 
Sub Harness_Search()

'=TEXTJOIN(", ", TRUE, IF( COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))
Dim input_data() As Variant, X As Long, Y As Long, output() As String, _
harness_numbers() As Variant, Z As Long, Harness_CLCTN As Collection, value() As String

With ThisWorkbook.ActiveSheet

    input_data = .Range(.Range("J2"), .Range("L" & .UsedRange.Rows.Count)).Value2
    harness_numbers = .Range(.Range("Y2"),  .Range("Y" & .UsedRange.Rows.Count)).Value2
End With

Const delimiter As String = ", "

ReDim output(LBound(input_data, 1) To UBound(input_data, 1), 1 To 1)

For X = LBound(input_data, 1) To UBound(input_data, 1)

    Set Harness_CLCTN = New Collection
  
    With Harness_CLCTN
  
        For Y = LBound(input_data, 2) To UBound(input_data, 2)
      
            If Not input_data(X, Y) = Empty Then
          
                For Z = LBound(harness_numbers, 1) To UBound(harness_numbers, 1)
                    'patterns:
                    'code and any non-alphanumeric character + *
                    'code at the end of string
                    'code followed by a space and any number of characters
                    If Not harness_numbers(Z, 1) = Empty _
                    And (input_data(X, Y) Like "*" & harness_numbers(Z, 1) & "[!A-Za-z0-9]*" _
                    Or input_data(X, Y) Like "*" & harness_numbers(Z, 1)) Then
                      
                        On Error Resume Next
                        .Add harness_numbers(Z, 1), harness_numbers(Z, 1)
                  
                    End If
                  
                Next Z
              
            End If
        Next Y
      
        If .Count > 0 Then
            ReDim value(1 To .Count)
            For Z = 1 To .Count
                value(Z) = .Item(Z)
            Next Z
            output(X, 1) = Join(value, delimiter)
        End If
  
    End With
  
Next X

With ThisWorkbook.ActiveSheet
    .Range(.Range("M2"), .Range("M" & .UsedRange.Rows.Count)).Value2 = output
End With

End Sub
Click to expand...

Wow. That appears to have worked. If you have time, would please break that down a little for me? If I understood it a little bit maybe I could adapt it. For example, what if I had another list of values in column Z, and still wanted to search J,K,L, but return in column N? Thank you so much!
 
Upvote 0
MoshiM said:
Here's another one. It may be faster depending on how large your data set is.
VBA Code: 
Sub Harness_Search()

'=TEXTJOIN(", ", TRUE, IF( COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))
Dim input_data() As Variant, X As Long, Y As Long, output() As String, _
harness_numbers() As Variant, Z As Long, Harness_CLCTN As Collection, value() As String

With ThisWorkbook.ActiveSheet

    input_data = .Range(.Range("J2"), .Range("L" & .UsedRange.Rows.Count)).Value2
    harness_numbers = .Range(.Range("Y2"),  .Range("Y" & .UsedRange.Rows.Count)).Value2
End With

Const delimiter As String = ", "

ReDim output(LBound(input_data, 1) To UBound(input_data, 1), 1 To 1)

For X = LBound(input_data, 1) To UBound(input_data, 1)

    Set Harness_CLCTN = New Collection
  
    With Harness_CLCTN
  
        For Y = LBound(input_data, 2) To UBound(input_data, 2)
      
            If Not input_data(X, Y) = Empty Then
          
                For Z = LBound(harness_numbers, 1) To UBound(harness_numbers, 1)
                    'patterns:
                    'code and any non-alphanumeric character + *
                    'code at the end of string
                    'code followed by a space and any number of characters
                    If Not harness_numbers(Z, 1) = Empty _
                    And (input_data(X, Y) Like "*" & harness_numbers(Z, 1) & "[!A-Za-z0-9]*" _
                    Or input_data(X, Y) Like "*" & harness_numbers(Z, 1)) Then
                      
                        On Error Resume Next
                        .Add harness_numbers(Z, 1), harness_numbers(Z, 1)
                  
                    End If
                  
                Next Z
              
            End If
        Next Y
      
        If .Count > 0 Then
            ReDim value(1 To .Count)
            For Z = 1 To .Count
                value(Z) = .Item(Z)
            Next Z
            output(X, 1) = Join(value, delimiter)
        End If
  
    End With
  
Next X

With ThisWorkbook.ActiveSheet
    .Range(.Range("M2"), .Range("M" & .UsedRange.Rows.Count)).Value2 = output
End With

End Sub
Click to expand...
Also, when I tried it on my 100,000 line file, it immediately locked up. I let it spin for about 20 mins.
 
Upvote 0
@plk0507
Here's another option:
There are 2 steps:
1. Sort col Y by text length.
VBA Code: 
Sub sortByLength()

va = Range("y2", Cells(Rows.Count, "y").End(xlUp))
n = UBound(va, 1)
ReDim vb(1 To n, 1 To 1)

For i = 1 To n

vb(i, 1) = Len(va(i, 1))
Next

Range("z2").Resize(n, 1) = vb
With Range("y2").Resize(n, 2)
    .Sort Key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo
End With

End Sub
So it would look like this:
Book1
YZ
1Harness Number
2W16445
3W16545
4W18445
5W18125
6W26905
7W26825
8W2694
9W2684
Sheet2

This step is necessary to deal with the partial search problem.

2. Use Instr & Replace function
VBA Code: 
Sub plk0507()
Dim i As Long, j As Long, n As Long, p As Long
Dim tx As String
Dim va, vb, vc, x
t = Timer
n = Range("J" & Rows.Count).End(xlUp).Row
va = Range("J2:L" & n)
n = UBound(va, 1)
ReDim vc(1 To n, 1 To 1)
vb = Range("y2", Cells(Rows.Count, "y").End(xlUp))

For i = 1 To n
    tx = ""
    For j = 1 To 3
        tx = tx & "|" & va(i, j)
        
    Next
    p = Len(tx)
    For Each x In vb
        If InStr(tx, x) Then
            tx = Replace(tx, x, "")
            If Len(tx) <> p Then
                vc(i, 1) = vc(i, 1) & "," & x
                p = Len(tx)
            End If
        End If
    Next
    vc(i, 1) = Mid(vc(i, 1), 2, 10000)


Next

Range("M2").Resize(n, 1) = vc
Debug.Print "It's done in:  " & Timer - t & " seconds"
End Sub

Book1
M
1Harness
2W1644,W1654,W1844
3W1812,W2690
4W1812,W2690
5W1644,W1654,W1844
6W2690
7W269
8W2682
9W2690
10W2690
11W2690
Sheet2


But because your data is so large, 3 column with 900K rows , and 6K Harness Number then we need in multiple parts, probably per 10K rows.
Please try it on 10K rows first, in the immediate window see how long it take to finish. If it works I'll amend the code to do it in multiple parts.
 
Upvote 0
This code assumes that you will always want to query columns J through L. You can add Source Columns for codes and their destination range by adding lines similar to "Comparison_CLCTN.Add Array("Y", "M") " near the top where the rest of them are specified.

I've added a DoEvents condition so you can retain some usage while the script is running. Lower the number at the end of the loop if it interferes with what you want to do.

VBA Code: 
Sub Harness_Search()

'=TEXTJOIN(", ", TRUE, IF( COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))
Dim input_data() As Variant, X As Long, Y As Long, output() As String, ITR As Variant, T As Long, _
harness_numbers() As Variant, Z As Long, value() As String, Comparison_CLCTN As New Collection, Query As Collection

With ThisWorkbook.ActiveSheet

    input_data = .Range(.Range("J2"), .Range("L" & .UsedRange.Rows.Count)).Value2 'Data from columns J through L
 
    ReDim output(LBound(input_data, 1) To UBound(input_data, 1), 1 To 1)
 
    Comparison_CLCTN.Add Array("Y", "M") 'Source of codes followed by output column
    Comparison_CLCTN.Add Array("Z", "N") 'Source of codes followed by output column
 
    For Z = Comparison_CLCTN.Count To 1 Step -1
 
        ITR = Comparison_CLCTN(Z)
     
        Set Query = New Collection
     
        Query.Add .Range(ITR(0) & "2", ITR(0) & .UsedRange.Rows.Count).Value2, "CODES"
        Query.Add .Range(ITR(1) & "2", ITR(1) & .UsedRange.Rows.Count), "DESTINATION RANGE"
        Query.Add output, "OUTPUT"
        Query.Add New Collection, "STORAGE"
     
        Comparison_CLCTN.Remove Z
        Comparison_CLCTN.Add Query
     
    Next Z
 
End With

Const delimiter As String = ", "

For X = LBound(input_data, 1) To UBound(input_data, 1) 'Loop each ROW of columns J through L

    For Y = LBound(input_data, 2) To UBound(input_data, 2) 'Loop each COLUMN from J to L
 
        If Not input_data(X, Y) = Empty Then
     
            With Comparison_CLCTN
         
                For T = 1 To .Count
             
                    With .Item(T) 'With given values of (codes and destination ranges search columns J-L
                     
                        harness_numbers = .Item("CODES")
                     
                        For Z = LBound(harness_numbers, 1) To UBound(harness_numbers, 1) 'Loop though each Harness Number from column Y
                            'patterns:
                            'code and any non-alphanumeric character + *
                            'code at the end of string
                            'code followed by a space and any number of characters
                         
                            If Not harness_numbers(Z, 1) = Empty _
                            And (input_data(X, Y) Like "*" & harness_numbers(Z, 1) & "[!A-Za-z0-9]*" _
                                Or input_data(X, Y) Like "*" & harness_numbers(Z, 1)) Then
                             
                                On Error Resume Next
                             
                                .Item("STORAGE").Add harness_numbers(Z, 1), harness_numbers(Z, 1)
                             
                                On Error GoTo 0
                             
                            End If
                         
                        Next Z
                     
                    End With
                 
                Next T
             
            End With
         
        End If
     
    Next Y
 
    With Comparison_CLCTN   'Loop through combination of source and destination
        For T = 1 To .Count
            Set Query = .Item(T)
            With Query
 
                output = .Item("OUTPUT")
             
                With .Item("STORAGE")
                    If .Count > 0 Then
                        ReDim value(1 To .Count)
                        For Z = .Count To 1 Step -1
                            value(Z) = .Item(Z)
                            .Remove Z
                        Next Z
                        output(X, 1) = Join(value, delimiter)
                        
                        Query.Remove "OUTPUT"
                        Query.Add output, "OUTPUT"
                    End If
                End With
                    
            End With
        Next T
    End With
 
    If X Mod 3000 = 0 Then DoEvents
 
Next X

With ThisWorkbook.ActiveSheet
    For Each ITR In Comparison_CLCTN
        ITR("DESTINATION RANGE").Value2 = ITR("OUTPUT")
    Next ITR
End With

msgbox "Search completed."
End Sub
 
Last edited:
Upvote 0
MoshiM said:
This code assumes that you will always want to query columns J through L. You can add Source Columns for codes and their destination range by adding lines similar to "Comparison_CLCTN.Add Array("Y", "M") " near the top where the rest of them are specified.

I've added a DoEvents condition so you can retain some usage while the script is running. Lower the number at the end of the loop if it interferes with what you want to do.
Click to expand...
Something that Akuni wrote reduced the Big O so I added it
VBA Code: 
Sub Harness_Search()

'=TEXTJOIN(", ", TRUE, IF( COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))
Dim input_data() As Variant, X As Long, Y As Long, output() As String, ITR As Variant, T As Long, _
harness_numbers() As Variant, Z As Long, value() As String, Comparison_CLCTN As New Collection, Query As Collection, row_str As String

With ThisWorkbook.ActiveSheet

    input_data = .Range(.Range("J2"), .Range("L" & .UsedRange.Rows.Count)).Value2 'Data from columns J through L
   
    ReDim output(LBound(input_data, 1) To UBound(input_data, 1), 1 To 1)
   
    Comparison_CLCTN.Add Array("Y", "M") 'Source of codes followed by output column
    Comparison_CLCTN.Add Array("Z", "N") 'Source of codes followed by output column
   
    For Z = Comparison_CLCTN.Count To 1 Step -1
   
        ITR = Comparison_CLCTN(Z)
       
        Set Query = New Collection

        Query.Add .Range(ITR(0) & "2", ITR(0) & .UsedRange.Rows.Count).Value2, "CODES"
        Query.Add .Range(ITR(1) & "2", ITR(1) & .UsedRange.Rows.Count), "DESTINATION RANGE"
        Query.Add output, "OUTPUT"
        Query.Add New Collection, "STORAGE"
       
        Comparison_CLCTN.Remove Z
        Comparison_CLCTN.Add Query
       
    Next Z
   
End With

Const delimiter As String = ", "

With Comparison_CLCTN

    For X = LBound(input_data, 1) To UBound(input_data, 1) 'Loop each ROW of columns J through L
   
        row_str = vbNullString
        For Y = LBound(input_data, 2) To UBound(input_data, 2) 'Loop each COLUMN from J to L
            row_str = row_str & "|" And input_data(X, Y)
        Next Y
       
        If Not row_str = vbNullString Then
       
            For T = 1 To .Count
           
                With .Item(T) 'With given values of (codes and destination ranges search columns J-L
                   
                    harness_numbers = .Item("CODES")
                   
                    For Z = LBound(harness_numbers, 1) To UBound(harness_numbers, 1) 'Loop though each Harness Number from column Y
                        'patterns:
                        'code and any non-alphanumeric character + *
                        'code at the end of string
                        'code followed by a space and any number of characters
                       
                        If Not harness_numbers(Z, 1) = Empty _
                        And (row_str Like "*" & harness_numbers(Z, 1) & "[!A-Za-z0-9]*" _
                            Or row_str Like "*" & harness_numbers(Z, 1)) Then
                           
                            On Error Resume Next
                           
                            .Item("STORAGE").Add harness_numbers(Z, 1), harness_numbers(Z, 1)
                           
                            On Error GoTo 0
                           
                        End If
                       
                    Next Z
                   
                End With
               
            Next T
               
        End If
   
        For T = 1 To .Count 'Loop through combination of source and destination
            Set Query = .Item(T)
            With Query
   
                output = .Item("OUTPUT")
               
                With .Item("STORAGE")
                    If .Count > 0 Then
                        ReDim value(1 To .Count)
                        For Z = .Count To 1 Step -1
                            value(Z) = .Item(Z)
                            .Remove Z
                        Next Z
                        output(X, 1) = Join(value, delimiter)
                       
                        Query.Remove "OUTPUT"
                        Query.Add output, "OUTPUT"
                    End If
                End With
                      
            End With
        Next T

        If X Mod 5000 = 0 Then DoEvents
       
    Next X

End With

With ThisWorkbook.ActiveSheet
    For Each ITR In Comparison_CLCTN
        ITR("DESTINATION RANGE").Value2 = ITR("OUTPUT")
    Next ITR
End With

MsgBox "Search Completed."

End Sub
 
Last edited:
Upvote 0
Also swap out the lines where "CODES" and "DESTINATION RANGE" are added to the collection near the top with:
VBA Code: 
        Query.Add .Range(ITR(0) & "2", .Cells(.Rows.Count, ITR(0)).End(xlUp)).Value2, "CODES"
        Query.Add .Range(ITR(1) & "2", .Cells(.Rows.Count, ITR(1)).End(xlUp)), "DESTINATION RANGE"
 
Upvote 0
MoshiM said:
Also swap out the lines where "CODES" and "DESTINATION RANGE" are added to the collection near the top with:
VBA Code: 
        Query.Add .Range(ITR(0) & "2", .Cells(.Rows.Count, ITR(0)).End(xlUp)).Value2, "CODES"
        Query.Add .Range(ITR(1) & "2", .Cells(.Rows.Count, ITR(1)).End(xlUp)), "DESTINATION RANGE"
Click to expand...
disregard the second addition
 
Upvote 0
My apologies for spamming. I just keep finding better ways to write the code.
VBA Code: 
Sub Harness_Search()

'=TEXTJOIN(", ", TRUE, IF( COUNTIF(J2:L2, "*"&$Y$2:$Y$9&"*"), $Y$2:$Y$9, ""))
Dim input_data() As Variant, X As Long, Y As Long, output() As String, ITR As Variant, T As Long, _
harness_numbers() As Variant, Z As Long, value() As String, Comparison_CLCTN As New Collection, Query As Collection, row_str As String

With ThisWorkbook.ActiveSheet

    input_data = .Range("J2", "L" & .UsedRange.Rows.Count).Value2 'Data from columns J through L
    
    ReDim output(LBound(input_data, 1) To UBound(input_data, 1), 1 To 1)
    
    Comparison_CLCTN.Add Array("Y", "M") 'Source of codes followed by output column
    Comparison_CLCTN.Add Array("Z", "N") 'Source of codes followed by output column
    
    For Z = Comparison_CLCTN.Count To 1 Step -1
    
        ITR = Comparison_CLCTN(Z)
        
        Set Query = New Collection
         
        Query.Add .Range(ITR(0) & "2", .Cells(.Rows.Count, ITR(0)).End(xlUp)).Value2, "CODES"
        Query.Add .Range(ITR(1) & "2", ITR(1) & .UsedRange.Rows.Count), "DESTINATION RANGE"
        
        Query.Add output, "OUTPUT"

        Comparison_CLCTN.Remove Z
        Comparison_CLCTN.Add Query
        
    Next Z
    
End With

Const delimiter As String = ", "

With Comparison_CLCTN

    For X = LBound(input_data, 1) To UBound(input_data, 1) 'Loop each ROW of columns J through L
    
        row_str = vbNullString
        
        For Y = LBound(input_data, 2) To UBound(input_data, 2) 'Loop each COLUMN from J to L and generate a string to be searched
            row_str = row_str & "|" & input_data(X, Y)
        Next Y
        
        If Not row_str = vbNullString Then
        
            For T = 1 To .Count 'Loop Comparison_CLCTN
            
                With .Item(T) 'With given values of (codes,destination ranges,etc)
                    
                    harness_numbers = .Item("CODES")
                    output = .Item("OUTPUT")
                    
                    For Z = LBound(harness_numbers, 1) To UBound(harness_numbers, 1) 'Loop though each Harness Number from column Y
                        'patterns:
                        'Any string + code + any non-alphanumeric character + Any string(includes empty string)
                        'Any string + code
                        
                        If Not harness_numbers(Z, 1) = Empty _
                        And (row_str Like "*" & harness_numbers(Z, 1) & "[!A-Za-z0-9]*" _
                            Or row_str Like "*" & harness_numbers(Z, 1)) Then
                            
                            output(X, 1) = output(X, 1) & IIf(output(X, 1) = Empty, vbNullString, delimiter) & harness_numbers(Z, 1)

                        End If
                        
                    Next Z
                    
                    If Not output(X, 1) = Empty Then 'If pattern matches were found
                        .Remove "OUTPUT"
                        .Add output, "OUTPUT"
                    End If
                    
                End With
                
            Next T
                
        End If
        
        If X Mod 3000 = 0 Then DoEvents 'Allow user interaction with Excel every 3000 loops
        
    Next X

End With

With ThisWorkbook.ActiveSheet
    For Each ITR In Comparison_CLCTN
        ITR("DESTINATION RANGE").Value2 = ITR("OUTPUT")
    Next ITR
End With

MsgBox "Search Completed."

End Sub
 
Upvote 0
I appreciate it! I'm back at it this morning and I'll let you know how it goes! Thank you!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Cut and Paste certain cells of certain rows / if bored code optimization
Replies
0
Views
950
BobHex
B

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top