Hello,

I'm new to VBA and everything I've compiled so far is from help with other Excel forum members and online Searches. I'm working on creating a Cypher in which I could use to communicate with those who have a matching Cypher key using Excel. Part of the set up process (in order for more efficient running of the cypher on a slower computer) is to run a search and paste all those search results into a column and the next results into the next column and so on and so forth. The code I have posted works so far but I need to be able to use the cells in the first row as my search criteria in order to connect the circle and have Excel automatically finish populating the search results.

I have included the file with the original code. Go to the Srch Tab, Click Find All Button, and type in a letter. Excel will do all the work and all you have to do is go to the Srch Tab and pick another letter (one that corresponds to the next column.

This code, instead of continuing with the 2nd Row, it ends on the first row of the column with the next search criteria I want to use. How do I get VBA to search for that particular cell it lands on and how do I get it to stop when it lands on a blank cell?

Thanks in advance for your help.

~MsBBS


Sub FindCopyAll_Alt()
'
' FindCopyAll_Alt Macro
''I am using row one for labels so my first usable row is row 2
pos = 2
'
'I want to delete the "Search Results" sheet if it exists, So I am going to force an error
On Error GoTo NewSheet
'
'This blocks the message "Deleting Sheet Will Lose Data"
Application.DisplayAlerts = False
'
'This selects the results sheet, if it does not exist then we will go to NewSheet
Sheets("Search Results").Select
'
'This Deletes the Results Sheet
ActiveSheet.Delete
'
'This re-enables our error messages
Application.DisplayAlerts = True
'
'Create the Results Sheet
NewSheet:
   Sheets.Add After:=ActiveSheet
   ActiveSheet.Name = "Search Results"
   ActiveSheet.Move Before:=Sheets(1)
'What Text do you want to search for?
MyStr = InputBox("Enter Text to Find", "Find Text Macro", "select", 100, 100)
'
'These are my Labels
Range("E1").Value = "Recommended Shortcuts:"
Range("F2").Value = "CTRL + SHIFT + V"
Range("F3").Value = "CTRL + SHIFT + C"
Range("F4").Value = "CTRL + SHIFT + X"
Range("F5").Value = "CTRL + SHIFT + Z"
Range("H3").Value = "_"
Range("H4").Value = ",_"
Range("H5").Value = ".__"
Range("I2").Value = "(Compile A1 List ONLY)"
Range("I3").Value = "(Compile A1 List and SPACE)"
Range("I4").Value = "(Compile A1 List, COMA, SPACE) "
Range("I5").Value = "(Compile A1 List, PERIOD, SPACE, SPACE)"
Range("B1").Value = "Rand"
'
'This resets our normal error routines
On Error GoTo 0
'
'Quit if search text is empty
If MyStr = "" Then Exit Sub
'
'Search for the Search String in each workbook except the results sheet
For Each ws In Sheets
'
If ws.Name = "Search Results" Then GoTo Skip
If ws.Name = "Srch" Then GoTo Skip
If ws.Name = "Rand" Then GoTo Skip
'
MyName = ws.Name
'
   MyString = ""
'
   With ws.Cells
      Set rngFind = .Find(MyStr, .Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
      If Not rngFind Is Nothing Then
           strFirstAddress = rngFind.Address
'
           Do
                MyString = MyString & MyName & "!" & rngFind.Address & ", "
                Set rngFind = .FindNext(rngFind)
           Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
      End If
    End With
'
'If Match Found then store data in Column A of results sheet
     If MyString <> "" Then
'
'Convert MyString into an Array, so it is easy to save
     MyArray = Split(MyString, ",")
'
'Where to save MyArray
     Temp = Range(Cells(pos, 1), Cells(pos + UBound(MyArray), 1)).Address
'
'Save MyArray, The array is horizontal, transpose makes it vertical
     Sheets("Search Results").Range(Temp).Value = Application.Transpose(MyArray)
'
'We need to increment pos so the next lot of data is saved below the existing data
     pos = pos + UBound(MyArray)
'
   End If
'
Skip:
Next

'This Adds Randomizer Column
With Sheets("Search Results")

'Number of times Loop is ran
For Count = 2 To pos - 1


Temp = CStr(Application.Trim(Sheets("Search Results").Cells(Count, 1)))
'
Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Formula = "=Rand()"
Exit For
Next
'
    Range("B2").Select
    Selection.End(xlDown).Select
    Selection.ClearContents
    Selection.End(xlUp).Select
    Selection.End(xlUp).Select
End With

'Copy and Paste Column A - Delete This and downward after Rand Set up
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("A2:A1353").Select
    Selection.Copy
    Sheets("Rand").Select
    ActiveSheet.Paste
                   'Select Row 1 Change back to (0, 1) if continued code isn't working
    ActiveCell.Offset(-1, 1).Range("A1").Select
    
'Attempting to use cell contents as my find all criteria
'Continuing Code needs to go here
End Sub
Sample.xlsm