Solved: Find cell value from a range & resize and copy to a worksheet

Hi All.

I would really appreciate some help to refine a macro that i have been working on.

I am trying to copy a selected range from a row which will be determined by the user via an input box, the cell values will then be pasted to another worksheet and ultimately applying this macro to all worksheets within a workbook.

I.e The range that is to be searched will be A1:A200. I require the found cell and the following 10 cells to the right of the activecell to be copied and pasted in another worksheet.

The code i have so far is as follows. I continue to get an error relating to the search range.

[vba]Sub zzz()
Dim wks As Worksheet

'Clears the content of the report page prior to new data being pasted.
With sheet3
.Range(.Cells(2, 1), .Cells(Rows.Count, 17)).ClearContents


Dim myinput As String
myinput = InputBox("Enter No. of weeks")

For Each wks In ThisWorkbook.Worksheets

'I would include the following code, if i did not wish for certain worksheets
'to be excluded from the macro

'If Not wks Is sheet3 _
And Not wks.Name = "sheet2" _
And Not wks.Name = "sheet4" Then

'##########################################################################

'*****My error lies here*****

Range("A1:A100").Select
Selection.Find(What:=myinput, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select

'##########################################################################

wks.Range("A" & ActiveCell.Row).Resize(, 10).Copy

Sheets("Sheet3").Select
Range("a5000").End(xlUp).Select
ActiveCell.Offset(1, 0).Select


ActiveSheet.Paste
'End If
Next wks

End With
End Sub[/vba]

Any assistance would be gratefully appreciated.

Thanks

BT

I've not looked at your workbook, so untested:
[vba]Sub zzz()
Dim wks As Worksheet

'Clears the content of the report page prior to new data being pasted.
With sheet3
'.Range(.Cells(2, 1), .Cells(Rows.Count, 17)).ClearContents
Dim myinput As String
myinput = InputBox("Enter No. of weeks")
For Each wks In ThisWorkbook.Worksheets
'I would include the following code, if i did not wish for certain worksheets
'to be excluded from the macro

'If Not wks Is sheet3 _
And Not wks.Name = "sheet2" _
And Not wks.Name = "sheet4" Then
Set myFind = wks.Range("A1:A100").Find(What:=myinput, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not myFind Is Nothing Then
wks.Range("A" & myFind.Row).Resize(, 10).Copy
Sheets("Sheet3").Select
Range("a5000").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next wks
End With
End Sub

[/vba]

Hi P45cal,

Thank you very much for your help. Ur bit of code did the trick to get the macro up and running.

If i wanted to also copy a couple of additional ranges such as A1 & N6, how would i include that in the macro.

I tried the union option but no luck on that.

[vba]Dim Rng1, Rng2 As Range

Set Rng1 = wks.Range("A" & myFind.Row).Resize(, 10)
Set Rng2 = Range("A1, N6")

'Union(Rng1, Rng2).Copy[/vba]

put these two lines after current Activesheet.paste:
[VBA]wks.Range("A1").Copy ActiveCell.Offset(, 10)
wks.Range("N6").Copy ActiveCell.Offset(, 11)
[/VBA]

P45cal,

Amazed at your knowledge. Once again, thank you for your help.

BT

To avoid Selection, adjust these lines
[VBA]
If Not myFind Is Nothing Then
Set tgt = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
wks.Range("A" & myFind.Row).Resize(, 10).Copy tgt
End If

wks.Range("A1").Copy tgt.Offset(, 10)
wks.Range("N6").Copy tgt.Offset(, 11)

[/VBA]