Related:
- Macro to copy row in new sheet if text found
- Little alchemy cheat sheet - Guide
- Excel macro to create new sheet based on value in cells - Guide
- Google sheet right to left - Guide
- Spell number in excel without macro - Guide
- Saints row 2 cheats - Guide
1 response
So far I ahve this code. The only rpoblem is that it is only able to find cells that only have one word. for examble if I search for "you" it finds and copy as long as the cell has only "you".
If the cell has "you and only you" the code those not recognize this as containing you.
Help will be appreciated.
Public Sub Tester()
Dim Rng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destRng As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim CalcMode As Long
Dim arr As Variant
Dim res As Variant
Set WB = ActiveWorkbook
Set SH = WB.Sheets("Codigos")
Set Rng = SH.Range("A5:G188")
Set destRng = WB.Sheets("Resultados").Range("A5")
res = InputBox("Enter search words separated with a space")
If res = "" Then Exit Sub
arr = Split(res, " ")
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In Rng.Cells
If Not IsError(Application.Match(rCell.Value, arr, 0)) Then
If copyRng Is Nothing Then
Set copyRng = rCell
Else
Set copyRng = Union(rCell, copyRng)
End If
End If
Next rCell
If Not copyRng Is Nothing Then
copyRng.EntireRow.Copy Destination:=destRng
Else
'nothing found, do nothing
End If
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
If the cell has "you and only you" the code those not recognize this as containing you.
Help will be appreciated.
Public Sub Tester()
Dim Rng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destRng As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim CalcMode As Long
Dim arr As Variant
Dim res As Variant
Set WB = ActiveWorkbook
Set SH = WB.Sheets("Codigos")
Set Rng = SH.Range("A5:G188")
Set destRng = WB.Sheets("Resultados").Range("A5")
res = InputBox("Enter search words separated with a space")
If res = "" Then Exit Sub
arr = Split(res, " ")
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In Rng.Cells
If Not IsError(Application.Match(rCell.Value, arr, 0)) Then
If copyRng Is Nothing Then
Set copyRng = rCell
Else
Set copyRng = Union(rCell, copyRng)
End If
End If
Next rCell
If Not copyRng Is Nothing Then
copyRng.EntireRow.Copy Destination:=destRng
Else
'nothing found, do nothing
End If
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
