PDA

View Full Version : [SOLVED] Find and show another sheet (adaptation)



elsg
09-08-2015, 05:27 AM
how adapt ron de bro=in code to find based cell ?


Option Explicit
Sub Copy_To_Another_Sheet_1()
Dim FirstAddress As String
Dim MyArr As Variant
Dim rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet

Dim InCellRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Fill in the search Value
InCellRng = Worksheets("FindSht").Range("B4").Value 'Array("bat")

'You can also use more values in the Array
'myArr = Array("@", "www")

'Add new worksheet to your workbook to copy to
'You can also use a existing sheet like this
'Set NewSh = Sheets("Sheet2")
Set NewSh = Worksheets.Add

With Sheets("Cadastro de Itens").Range("C6:C1000")

Rcount = 0

For I = LBound(InCellRng) To UBound(InCellRng)

'If you use LookIn:=xlValues it will also work with a
'formula cell that evaluates to "@"
'Note : I use xlPart in this example and not xlWhole
Set rng = .Find(what:=InCellRng(I), _
after:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Rcount = Rcount + 1

rng.Copy NewSh.Range("A" & Rcount)

' Use this if you only want to copy the value
' NewSh.Range("A" & Rcount).Value = Rng.Value

Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
Next I
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
End With End Sub
Cross-Post
http://www.excelforum.com/excel-programming-vba-macros/1101566-find-and-show-another-sheet-adaptation.html

Thank you!!

mancubus
09-08-2015, 03:00 PM
it's not clear what you are looking for?
can you elaborate it?

provide a link to the original code.
upload a file where possible.

elsg
09-09-2015, 04:48 AM
This page:http://www.rondebruin.nl/win/s9/win006.htm (Copy cells to another sheet with Find)
This code find value in Array, i want use cell.

'Fill in the search Value
MyArr = Array("@") 'I want in cell

mancubus
09-09-2015, 05:49 AM
you want to find the cells in Worksheets("Cadastro de Itens").Range("C6:C1000") that contain Worksheets("FindSht").Range("B4").Value, and when found, copy found cell's value to column A in new blank sheet one after another?


Option Explicit

Sub vbax_53689_CopyFoundCellsToAnotherSheet()

Dim FirstAddress As String
Dim rng As Range
Dim NewSh As Worksheet
Dim InCellRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set InCellRng = Worksheets("FindSht").Range("B4")
Set NewSh = Worksheets.Add

With Worksheets("Cadastro de Itens").Range("C6:C1000")
Set rng = .Find(what:=InCellRng.Value, _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
rng.Copy NewSh.Range("A" & Rows.Count).End(xlUp).Offset(1)
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With

End Sub

elsg
09-09-2015, 06:58 AM
you want to find the cells in Worksheets("Cadastro de Itens").Range("C6:C1000") that contain Worksheets("FindSht").Range("B4").Value, and when found, copy found cell's value to column A in new blank sheet one after another?

Yes.

I test your code, display erro 91
this line

rng.Copy NewSh.Range("A" & Rows.Count).End(xlUp).Offset(1)

mancubus
09-09-2015, 07:37 AM
missing line (Set NewSh = Worksheets.Add) added to the code

elsg
09-09-2015, 07:43 AM
Very nice, thank you!!!