neat fix to a gross line of code?

Hi Jimmy, this may not be what you're after, but at least it's shorter:

If InStr(Cells(ii, 3), "pre-start", vbTextCompare) > 0 Or Cells(ii, 3).Value = Empty Then

Please click the Add Reputation star below any helpful posts, and if you have your answer, mark your thread as SOLVED (Thread Tools up top). Thanks!-Lee

Hey Jindon,

Thanks for the help. This is what I ended up with:
I'm going to play around with your solution in a bit, see if I can learn anything.

My solution:

Sub KeepOnlyDuplications()
'Version 2.1
'Creates a new tabs with the sorted information. (non searched and non-found rows are deleted)
'Renames the tab to be alphabetical
'Runs multiple searchs on a single tab
'finds anything what has words containing what is being searched

Dim Coll1 As New Collection
Dim strings1 As String
Dim tempname As String
Dim tempname2 As String
Dim colours As Long
colours = 0

Dim aaa As String
Dim JJJ As Long
Dim i As Long
Dim ii As Long
Dim BlankstoSkip As Long
Dim cell As Range
Dim TrueFalse As Boolean


'Housekeeping
Dim Neat As Range
Dim NeatBook As Worksheet
Set NeatBook = ActiveSheet
Set Neat = Range(ActiveCell.Address)
Application.ScreenUpdating = False



aaa = "pre-start"
'pre-start, AR, 250h, 1m, 3m, 6m, 1y
i = 0
Do
Coll1.Add Application.InputBox("Type what you want to keep" & _
vbNewLine & _
vbNewLine & "Press [Cancel] to run the search using:" & _
vbNewLine & _
vbNewLine & strings1 & _
vbNewLine & " ", "Some stuff", aaa, Type:=2)
i = i + 1
strings1 = Coll1(i) & ", " & strings1
Loop Until Coll1(i) = False
Coll1.Remove (i)
'''''''''
'Sort Collection
SortCollection Coll1
strings1 = vbNullString
For i = 1 To Coll1.Count
strings1 = strings1 & ", " & Coll1(i)
Next i
'rename strings1
'''''''''
strings1 = Right(StrConv(Replace(strings1, "False, ", ""), 3), Len(StrConv(Replace(strings1, "False, ", ""), 3)) - 2)
'''''
'Collection here to save all searchs
'''''

'If MsgBox("This is what the program does." & vbNewLine & vbNewLine & "Run program on worksheet copy?" & vbNewLine & vbNewLine & "[Yes] = Create Backup", vbYesNo) = vbYes Then
Sheets(ActiveWorkbook.ActiveSheet.Name).Select
tempname = ActiveWorkbook.ActiveSheet.Name
tempname2 = tempname & " " & strings1
    Do While Len(tempname2) >= 31
    tempname2 = Application.InputBox("The name length of the new tab is greater then 31 characters." & vbNewLine _
    & "The automatically generatered name was: " & tempname & " " & strings1 & vbNewLine & "Please enter in a new name for the tab:", _
    "Select top of the column the program is search down.", tempname2, Type:=2)
    Loop
'End If



Sheets(ActiveWorkbook.ActiveSheet.Name).Copy After:=ActiveWorkbook.ActiveSheet
ActiveWorkbook.ActiveSheet.Name = tempname2
ActiveWorkbook.ActiveSheet.Tab.Color = 5535 + colours



Dim X1 As Range
Dim X2 As Range
BlankstoSkip = 10

Set X1 = Application.InputBox("Column containing the words to be searched.", "Select top of the column the program is search down.", "C4", Type:=8)
Set X1 = Range("C4")
X1.Select
Selection.End(xlDown).Select
Set X2 = Selection

For ii = 1 To BlankstoSkip + 1
Do While Not IsEmpty(X2.Offset(ii, 0))
Selection.End(xlDown).Select
Set X2 = Selection
ii = 1
Loop
Next ii


i = X2.Row

For Each cell In Range(X1, X2)
cell.Value = Replace(cell, ChrW(&HA0), vbNullString)
If Trim(cell) = vbNullString Then
Else
cell.Value = Trim(cell)
If cell = ChrW(&HA0) Then
cell.Value = vbNullString
Else
End If
End If
Next cell

For ii = 5 To i
If (Cells(ii, 3).Offset(-1, 0).Value) = vbNullString And UCase(Cells(ii, 3).Value) = vbNullString Then
Cells(ii, 3).Offset(-1, 0).EntireRow.Delete Shift:=xlUp
Else
End If

TrueFalse = False
For i = 1 To Coll1.Count
    If UCase(Cells(ii, 3).Value) Like UCase(Coll1(i)) Then
    TrueFalse = True
    End If
Next i

If TrueFalse = True Or UCase(Cells(ii, 3).Value) = vbNullString Then
    Else
    Cells(ii, 3).EntireRow.Delete Shift:=xlUp
    ii = ii - 1
End If
Next ii


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Range("B4").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Select
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Application.ScreenUpdating = True
NeatBook.Select
Neat.Select

End Sub



Public Sub SortCollection(ColVar As Collection)
    Dim oCol As Collection
    Dim i As Integer
    Dim i2 As Integer
    Dim iBefore As Integer
    If Not (ColVar Is Nothing) Then
        If ColVar.Count > 0 Then
            Set oCol = New Collection
            For i = 1 To ColVar.Count
                If oCol.Count = 0 Then
                    oCol.Add ColVar(i)
                Else
                    iBefore = 0
                    For i2 = oCol.Count To 1 Step -1
                        If LCase(ColVar(i)) < LCase(oCol(i2)) Then
                            iBefore = i2
                        Else
                            Exit For
                        End If
                    Next
                    If iBefore = 0 Then
                        oCol.Add ColVar(i)
                    Else
                        oCol.Add ColVar(i), , iBefore
                    End If
                End If
            Next
            Set ColVar = oCol
            Set oCol = Nothing
        End If
    End If
End Sub

I'm hoping to make the program Ask if they user wants to run the program more then once and accept all the inputs at the very start before it has started running. I think I would need a loop around the following bit of code:

aaa = "pre-start"
'pre-start, AR, 250h, 1m, 3m, 6m, 1y
i = 0
Do
Coll1.Add Application.InputBox("Type what you want to keep" & _
vbNewLine & _
vbNewLine & "Press [Cancel] to run the search using:" & _
vbNewLine & _
vbNewLine & strings1 & _
vbNewLine & " ", "Some stuff", aaa, Type:=2)
i = i + 1
strings1 = Coll1(i) & ", " & strings1
Loop Until Coll1(i) = False
Coll1.Remove (i)
'''''''''
'Sort Collection
SortCollection Coll1
strings1 = vbNullString
For i = 1 To Coll1.Count
strings1 = strings1 & ", " & Coll1(i)
Next i
'rename strings1
'''''''''
strings1 = Right(StrConv(Replace(strings1, "False, ", ""), 3), Len(StrConv(Replace(strings1, "False, ", ""), 3)) - 2)
'''''
'Collection here to save all searchs
'''''

'If MsgBox("This is what the program does." & vbNewLine & vbNewLine & "Run program on worksheet copy?" & vbNewLine & vbNewLine & "[Yes] = Create Backup", vbYesNo) = vbYes Then
Sheets(ActiveWorkbook.ActiveSheet.Name).Select
tempname = ActiveWorkbook.ActiveSheet.Name
tempname2 = tempname & " " & strings1
    Do While Len(tempname2) >= 31
    tempname2 = Application.InputBox("The name length of the new tab is greater then 31 characters." & vbNewLine _
    & "The automatically generatered name was: " & tempname & " " & strings1 & vbNewLine & "Please enter in a new name for the tab:", _
    "Select top of the column the program is search down.", tempname2, Type:=2)
    Loop
'End If

***I think I would need a loop and to change my variables to arrays or 2 dimensional collections? I'm not sure how to go about doing that.****

Let me know what you think.

Jimmy.