Greetings,
I'm working with a spreadsheet that has embedded VBA and it works great if it's searching all spreadsheets in the workbook, unfortunately only need to search one sheet titled "DATA" and receiving errors because I have objects in other sheets. I've tried playing around the VBA but I'm a novice. I'm sure this is a 30 second fix, and would be grateful to learn the answer.
Below is the untouched VBA. There are two macros that I can include as well if needed, but I believe the issue is in the VBA itself.
Thank you and eagerly look forward to your reply.
Signed,
John
-Code below -
Option Explicit
Private Sub btnClear_Click()
cleanCells
ActiveSheet.txtBox1.Activate
End Sub
Private Sub btnSearch_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim startPos As Integer
Dim searchWord As String
On Error GoTo errorHandler
searchWord = Trim(txtBox1.Text)
If searchWord = "" Or Len(searchWord) < 3 Then
MsgBox ("Please enter at least 3 characters and try again.")
Exit Sub
End If
' Clean up the previous result
cleanCells
Set wb = ActiveWorkbook
startPos = 7
For Each ws In wb.Worksheets
If LCase(ws.Name) <> "search" Then ' Skip the search sheet
startPos = search_data(searchWord, wb, ws, startPos)
End If
Next
' Back to the search page
wb.Worksheets(1).Select
ActiveSheet.txtBox1.Activate
MsgBox ("Done")
Exit Sub
errorHandler:
MsgBox (Err.Number & ": " & Err.Description)
End Sub
Private Function search_data(searchWord As String, wb As Workbook, ws As Worksheet, counter) As Integer
Dim cell As Range
Dim ws1 As Worksheet
Dim firstAddress As String ' So the search does not repeat from the top
Dim currentRow As Long
Dim visited(150000), arrayPos As Long
Dim i As Long
Dim alreadyVisited, hit As Boolean
On Error GoTo errorHandler
Set ws1 = wb.Worksheets(1)
arrayPos = 0
hit = False
With ws.Range("A:A,C:C,D:D")
Set cell = .Find(what:=Trim(searchWord), LookIn:=xlValues, Lookat:=xlPart, _
MatchCase:=False, searchorder:=xlByColumns)
If Not cell Is Nothing Then
' --- HIT ---
hit = True
firstAddress = cell.Address
currentRow = cell.Row
' ------------------------------------------
' Type the sheet name
' ------------------------------------------
ws1.Select
Range("a" & counter).Select
ActiveCell.FormulaR1C1 = ws.Name
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
counter = counter + 1
' ------------------------------------------
' Copy the header ... first row of a sheet
' ------------------------------------------
ws.Select
ws.Rows("1:1").Select
Selection.Copy
ws1.Select
Range("A" & counter).Select
ActiveSheet.Paste
Application.CutCopyMode = False
' Change the background color
ws1.Rows(counter & ":" & counter).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
counter = counter + 1
' ------------------------------------------
' Insert search hits
' ------------------------------------------
Do
alreadyVisited = False
' Find if the row is already copied
For i = 0 To UBound(visited) - 1
If visited(i) = "" Then
Exit For
Else
If currentRow = visited(i) Then
alreadyVisited = True
Exit For
End If
End If
Next i
If alreadyVisited = False Then
visited(arrayPos) = currentRow
arrayPos = arrayPos + 1
ws.Select
ws.Rows(cell.Row & ":" & cell.Row).Select
Selection.Copy
ws1.Select
Range("A" & counter).Select
ActiveSheet.Paste
Application.CutCopyMode = False
counter = counter + 1
End If
Set cell = .FindNext(cell)
currentRow = cell.Row
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End If
End With
>
' ------------------------------------------
ws.Select
ws.Range("A1").Select ' scroll the page to the top
If hit = True Then
search_data = counter + 1 ' return the current row number to insert with one row space
Else
search_data = counter
End If
Exit Function
errorHandler:
MsgBox (Err.Number & ": " & Err.Description)
search_data = counter + 1
End Function
Private Sub cleanCells()
Dim wb As Workbook
On Error GoTo errorHandler
Set wb = ActiveWorkbook
wb.Worksheets(1).Select
Range("A7").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Exit Sub
errorHandler:
MsgBox (Err.Number & ": " & Err.Description)
End Sub
Private Sub txtBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
btnSearch_Click
End If
End Sub
I'm working with a spreadsheet that has embedded VBA and it works great if it's searching all spreadsheets in the workbook, unfortunately only need to search one sheet titled "DATA" and receiving errors because I have objects in other sheets. I've tried playing around the VBA but I'm a novice. I'm sure this is a 30 second fix, and would be grateful to learn the answer.
Below is the untouched VBA. There are two macros that I can include as well if needed, but I believe the issue is in the VBA itself.
Thank you and eagerly look forward to your reply.
Signed,
John
-Code below -
Option Explicit
Private Sub btnClear_Click()
cleanCells
ActiveSheet.txtBox1.Activate
End Sub
Private Sub btnSearch_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim startPos As Integer
Dim searchWord As String
On Error GoTo errorHandler
searchWord = Trim(txtBox1.Text)
If searchWord = "" Or Len(searchWord) < 3 Then
MsgBox ("Please enter at least 3 characters and try again.")
Exit Sub
End If
' Clean up the previous result
cleanCells
Set wb = ActiveWorkbook
startPos = 7
For Each ws In wb.Worksheets
If LCase(ws.Name) <> "search" Then ' Skip the search sheet
startPos = search_data(searchWord, wb, ws, startPos)
End If
Next
' Back to the search page
wb.Worksheets(1).Select
ActiveSheet.txtBox1.Activate
MsgBox ("Done")
Exit Sub
errorHandler:
MsgBox (Err.Number & ": " & Err.Description)
End Sub
Private Function search_data(searchWord As String, wb As Workbook, ws As Worksheet, counter) As Integer
Dim cell As Range
Dim ws1 As Worksheet
Dim firstAddress As String ' So the search does not repeat from the top
Dim currentRow As Long
Dim visited(150000), arrayPos As Long
Dim i As Long
Dim alreadyVisited, hit As Boolean
On Error GoTo errorHandler
Set ws1 = wb.Worksheets(1)
arrayPos = 0
hit = False
With ws.Range("A:A,C:C,D:D")
Set cell = .Find(what:=Trim(searchWord), LookIn:=xlValues, Lookat:=xlPart, _
MatchCase:=False, searchorder:=xlByColumns)
If Not cell Is Nothing Then
' --- HIT ---
hit = True
firstAddress = cell.Address
currentRow = cell.Row
' ------------------------------------------
' Type the sheet name
' ------------------------------------------
ws1.Select
Range("a" & counter).Select
ActiveCell.FormulaR1C1 = ws.Name
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
counter = counter + 1
' ------------------------------------------
' Copy the header ... first row of a sheet
' ------------------------------------------
ws.Select
ws.Rows("1:1").Select
Selection.Copy
ws1.Select
Range("A" & counter).Select
ActiveSheet.Paste
Application.CutCopyMode = False
' Change the background color
ws1.Rows(counter & ":" & counter).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
counter = counter + 1
' ------------------------------------------
' Insert search hits
' ------------------------------------------
Do
alreadyVisited = False
' Find if the row is already copied
For i = 0 To UBound(visited) - 1
If visited(i) = "" Then
Exit For
Else
If currentRow = visited(i) Then
alreadyVisited = True
Exit For
End If
End If
Next i
If alreadyVisited = False Then
visited(arrayPos) = currentRow
arrayPos = arrayPos + 1
ws.Select
ws.Rows(cell.Row & ":" & cell.Row).Select
Selection.Copy
ws1.Select
Range("A" & counter).Select
ActiveSheet.Paste
Application.CutCopyMode = False
counter = counter + 1
End If
Set cell = .FindNext(cell)
currentRow = cell.Row
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End If
End With
>
' ------------------------------------------
ws.Select
ws.Range("A1").Select ' scroll the page to the top
If hit = True Then
search_data = counter + 1 ' return the current row number to insert with one row space
Else
search_data = counter
End If
Exit Function
errorHandler:
MsgBox (Err.Number & ": " & Err.Description)
search_data = counter + 1
End Function
Private Sub cleanCells()
Dim wb As Workbook
On Error GoTo errorHandler
Set wb = ActiveWorkbook
wb.Worksheets(1).Select
Range("A7").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Exit Sub
errorHandler:
MsgBox (Err.Number & ": " & Err.Description)
End Sub
Private Sub txtBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
btnSearch_Click
End If
End Sub
