PDA

View Full Version : Search and Replace Special



JTracker
04-19-2007, 08:56 AM
Hi Guys,

This is my first post so please be gentle. I have searched for quite some time and can't find what I am looking for, but see many similar requests.

I have a workbook with 30,000 rows/sheet, 10 sheets and 30 columns per sheet (approximately).

What I want to do is search for a part number (entered via userform) within each sheet, then copy entire row and paste special to a "Results" sheet. The paste special is crucial!

The part numbers are located in a single column on each sheet (same column) and there may be duplication across the sheets.

What I have almost works and was taken from bits and pieces of differnt posts, but I can't get the paste special from the selected items. It also searches every cell which takes a fair bit of time.

I have attached what I am using for your references.

Any help would be appreciated.

Thanks

mdmackillop
04-19-2007, 03:16 PM
Hi JTracker
Welcome to VBAX
Try this (untested) code
Option Explicit
Sub SearchandCopy()

Dim oSheet As Object
Dim Firstcell As Range
Dim NextCell As Range
Dim WhatToFind As Variant
Dim rCopyCells As Range
Dim FirstAddress As String
Dim Current As Worksheet
Dim c As Range
Dim Col As Long

'Set column to search
Col = 1

On Error GoTo Err

Set Current = Sheets("Result")
Application.ScreenUpdating = False
With Sheets("Result").Range("A2:DD1000")
.ClearContents
.ClearFormats
End With

WhatToFind = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2)

If WhatToFind = False Then GoTo Exits
For Each oSheet In ActiveWorkbook.Worksheets
If oSheet.Name <> "Result" Then
With oSheet.Columns(Col)
Set c = .Find(WhatToFind, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.EntireRow.Copy
Current.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
FirstAddress = ""
End If
Next
Exits:
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox "Sorry there has been an error please try again"
End
End Sub

JTracker
04-19-2007, 09:47 PM
Hi,

Thanks for the code but it's not quite working now.

The code now runs indefinitely and fills the searched page with the search results instead of the "Results" page.

Any further comments or ideas would be helpful.

Thanks

mdmackillop
04-20-2007, 12:41 AM
Change these lines
Set Current = Sheets("Result")
and
Set c = .Find(WhatToFind, LookIn:=xlValues, lookat:=xlWhole)

mdmackillop
04-20-2007, 05:43 AM
Can the same part number appear more than once on each sheet. If not, the code could be simplified.

JTracker
04-20-2007, 07:48 AM
Can I ask what you want those lines changed to?

To answer your next question about duplication per sheet, there should be only one occurance per sheet of the searched part number.

Thanks again

mdmackillop
04-20-2007, 08:00 AM
Option Explicit
Sub SearchandCopy()

Dim oSheet As Object
Dim WhatToFind As Variant
Dim Current As Worksheet
Dim c As Range
Dim Col As Long

'Set column to search
Col = 1

On Error GoTo Err

Set Current = Sheets("Result")
Application.ScreenUpdating = False
With Current.Range("A2:DD1000")
.ClearContents
.ClearFormats
End With

WhatToFind = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2)

If WhatToFind = False Then GoTo Exits
For Each oSheet In ActiveWorkbook.Worksheets
If oSheet.Name <> "Result" Then
With oSheet.Columns(Col)
Set c = .Find(WhatToFind, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
c.EntireRow.Copy
Current.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues
End If
End With
End If
Next
Exits:
Current.Cells(1, 1).Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox "Sorry there has been an error please try again"
End
End Sub

JTracker
04-20-2007, 08:45 AM
OK, now I get the following error.

Error # 1004 was generated by Microsoft Office Excel

Activate method of Range class failed.

mdmackillop
04-20-2007, 08:48 AM
Can you post a small sample of your workbook? Use Manage Attachments in the Go Advanced section.

JTracker
04-20-2007, 08:55 AM
I found this but the example workaround isn't clear either.

support.microsoft.com/kb/905164

mdmackillop
04-20-2007, 09:07 AM
This only seems to apply to filtered data, but if you wish to try it, change the Copy line to
Range(.Cells(c.Row, "A"), .Cells(c.Row, "IV").End(xlToLeft)).Copy

JTracker
04-20-2007, 09:35 AM
I seemed to be able to get this working as below:



Sub SearchandCopy()

Dim oSheet As Object
Dim Firstcell As Range
Dim NextCell As Range
Dim WhatToFind As Variant
Dim rCopyCells As Range
Dim FirstAddress As String
Dim Current As Worksheet
Dim c As Range
Dim Col As Long

'Set column to search
Col = 1

On Error GoTo Err

Set Current = Sheets("Result")
Application.ScreenUpdating = False
With Sheets("Result").Range("A2:DD65000")
.ClearContents
.ClearFormats
End With

WhatToFind = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2)

If WhatToFind = False Then GoTo Exits
For Each oSheet In ActiveWorkbook.Worksheets
If oSheet.Name <> "Result" Then
oSheet.Activate
oSheet.[a1].Activate
With oSheet.Columns(Col)
Set c = .Find(WhatToFind, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Range(Range("A" & ActiveCell.Row), Range("IV" & ActiveCell.Row).End(xlToLeft)).Copy
Current.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
FirstAddress = ""
End If
Next
Exits:
Application.ScreenUpdating = True
Sheets("Result").Select
Range("A1").Select
Exit Sub
Err:
If Err.Number <> 0 Then
Msg = "Error #" & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
MsgBox "Sorry there has been an error please try again"
End
End Sub


Thanks for all your help and I hope I can return the favour :thumb

mdmackillop
04-20-2007, 09:51 AM
OK; and you should be able to delete the Do loop, if you have only one product per page.