Hi guys,

Ive been having a play with some otherway to replace the long Find code that ive used in the past.

My current code is about 100 lines long which is pretty inefficent.

Ive been able to use my code with some other code Im using for another tool I have, though i need to extend on the below so that it looks at not only D:D but also E:E and then D:D and E:E on another WS.

So basically the code looks at my input names, matches my input in the 4 ranges and copies each of the matches to the 'Server Results' WS.

The catch is if its found on the second worksheet then the heading of that second WS be written and any other entires found in that WS be placed below this.


possible?


Sub FindStrings()
Dim Strings As Range
Dim MyStr   As Range
Dim LR      As Long
Dim wsOUT   As Worksheet

Dim ws1 As Worksheet 'Search
Dim SearchRng As Range
Set ws1 = Worksheets("Servers To Find")
Set SearchRng = ws1.Range("A1:A" & ws1.Cells(ws1.Cells.Rows.Count, 1).End(xlUp).Row)

Application.ScreenUpdating = False

'Loop through cells removing excess spaces in CRRng of Croff Ref Data WS
With Sheets("Servers To Find")
 
    For Each cl In SearchRng
        If Len(cl) > Len(WorksheetFunction.Trim(cl)) Then
            cl.Value = WorksheetFunction.Trim(cl)
        End If
    Next cl
 
End With


Set wsOUT = Sheets("Server Results")
wsOUT.Cells.Clear
Set Strings = Sheets("Servers To Find").Range("A:A").SpecialCells(xlConstants)

With Sheets("Physical Servers")
    .Range("A2").EntireRow.Copy wsOUT.Range("A1")
    .Range("D:D").AutoFilter
    
    For Each MyStr In Strings
        .Range("D:D").AutoFilter Field:=1, Criteria1:="*" & MyStr & "*"
        LR = .Range("P" & .Rows.Count).End(xlUp).Row
        If LR > 1 Then _
            .Range("A2:A" & LR).EntireRow.Copy _
               wsOUT.Range("A" & Rows.Count).End(xlUp).Offset(1)
    Next MyStr
    
    .Range("D:D").AutoFilter
End With

wsOUT.Columns.AutoFit
Set wsOUT = Nothing
Set Strings = Nothing
Application.ScreenUpdating = True
End Sub