Need assistance updating my Excel search find replace function

[iceyburnz]

-Excel 2003
I frequently receive emails from different teams asking if any of my
users are contained in the list. The data is laid out in different
fashions (I've included two examples. Names are not always in the first column)

Username   Hostname   Date       Location
johnsmith   computer1  4/29/11   5th floor
mikejones   computer2  4/29/11   3rd floor
bobsmith    computer3  4/29/11   3rd floor

Response   Admin    Floor    User  
Yes          Yes      3       Jim Doe
No           No       3       Jane Doe
Yes          No       4       Mike Smith

The script that we use currently works but now I want to change it and
I need some assistance. I need to update the script because every
time we get a new user(or someone leaves), i have to update my
personal.xls and then send my personal.xls out to the rest of the
members of my team. This is very inefficient because someone could miss the email and I would rather updatea single list in one central location and modify the script so that it
uses the list and searches.

The current script is stored in Personal.xls. The current script
selects all the cells in the current sheet, copies and pastes values
(in case there are any formulas), and then it searches for each of the
names and bolds it and changes the color of the name. There are currently about 300 items which need to be searched(not sure if this is relevant but I figured I'd include it)

Here is how I would like it to work (in my head):
1. I would like the script to pull a text file from an internal
website containing the list of items to search
2. Place the list into Personal.xls(or into a new sheet in the current workbook) starting in cell a1 and
going down (so A1 would have bobsmith, A2 would have janedoe, a3 would
have username3, etc)
3. Do a search for the value of A1 and if found bold/color the
matches. Then do a search for the value of A2 and if found bold/color
the matches, etc, etc (Maybe a for/next loop?)


My current script is below:

' Sub routine, copies and pastes special to ensure formulas aren't searched.

   Cells.Select
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   Application.CutCopyMode = False
   Range("A1").Select

'
   Cells.Select
   With Application.ReplaceFormat.Font
       .FontStyle = "Bold"
       .Subscript = False
       .ColorIndex = 4
   End With
   Selection.Replace What:="bobsmith", Replacement:="bobsmith", LookAt:= _
       xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
       ReplaceFormat:=True

   Selection.Replace What:="janedoe", Replacement:="janedoe", LookAt:= _
       xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
       ReplaceFormat:=True
Cells.Select
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   Application.CutCopyMode = False
   Range("A1").Select

'
   Cells.Select
   With Application.ReplaceFormat.Font
       .FontStyle = "Bold"
       .Subscript = False
       .ColorIndex = 3
   End With
   Selection.Replace What:="Bob Smith", Replacement:="Bob Smith", LookAt:= _
       xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
       ReplaceFormat:=True

   Selection.Replace What:="Jane Doe", Replacement:="Jane Doe", LookAt:= _
       xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
       ReplaceFormat:=True


End Sub

Anyone able to help would be much appreciated. Please let me know if I forgot anything or if any more info is needed

Thanks!

 

[iceyburnz]

I actually solved this on my own and I am posting the code in case any one has the same issue. Its probably not the neatest and has some unneccesary things so if any one has any suggestions, ill be glad to take note

Another question I had is that I currently dont have error checking built in(what if the sharepoint site is down?). Is there any way to tell the code to open the file from an alternate location if the first isnt accessible?

Sub NameSearch2()
 
Dim WB As Workbook
Dim WB2 As Workbook
Dim snam As String
Dim srcSH As Worksheet
Dim nameSH As Worksheet
Dim vipcsv As Worksheet
Dim srcRng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destRng As Range
Dim LastRow As Long
Dim LastuRow As Long
Dim CalcMode As Long
Dim resultsSH As Worksheet
 
 
 
Application.ScreenUpdating = False
 
 
 
Set WB = ActiveWorkbook
Set srcSH = ActiveWorkbook.ActiveSheet
Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
 
ActiveWorkbook.Sheets.Add '<<=== CHANGE
ActiveSheet.Name = "namescheck"
Set nameSH = Worksheets("namescheck")
 
Workbooks.Open Filename:= _
        "http://website address"
 
Set WB2 = ActiveWorkbook
Set vipcsv = ActiveSheet
Cells.Select
    Selection.Copy
 
WB.Activate
 
Selection.PasteSpecial xlValues
 
WB2.Activate
 
vipcsv.Select
Application.CutCopyMode = False
    ActiveWindow.Close
 

nameSH.Select
 
'get the last row
LastRow = Range("A65536").End(xlUp).Row
LastuRow = Range("C65536").End(xlUp).Row
 
For i = 2 To LastRow
 
nameSH.Select
    NameFromExcel = Range("A" & i).Value
    ReplaceFromExcel = Range("B" & i).Value
   
   
srcSH.Select
    Cells.Select
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .ColorIndex = 4
    End With
   
    Selection.Replace What:=NameFromExcel, Replacement:=ReplaceFromExcel, LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
nameSH.Select
Next i
 
For i = 2 To LastuRow
 
nameSH.Select
    UserFromExcel = Range("C" & i).Value
    ReplaceUFromExcel = Range("D" & i).Value
   
   
srcSH.Select
    Cells.Select
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .ColorIndex = 3
    End With
   
    Selection.Replace What:=UserFromExcel, Replacement:=ReplaceUFromExcel, LookAt:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
nameSH.Select
 
Next i
 

srcSH.Select
Application.DisplayAlerts = False
nameSH.Delete
Application.DisplayAlerts = True
 

Application.ScreenUpdating = True
 
 
 
End Sub