Find multiple criteria and paste to new worksheet

[mlglover]

I have a report that comes to me dumped into column A of Excel, and each month the report varies from 300 to 80000 rows. What I want to do is to find each cell in column “A” that contains the word “apple” or “oranges” or “banana” or Grapefruit”. Once all the occurrences have been found I want them to be pasted into worksheet2. So far the best that I can do is to find all the occurrences and have them either pasted in their own worksheet or a separate column on workseet2. This is what I have come up with thus far. Any assistance would greatly be appreciated.. The example that I have here doesn’t paste the found information into the next empty row.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
Sub apples()
<o> </o>
With Sheets("Sheet1").Select
End With
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1
<o> </o>
For sRow = 1 To Range(" A65536").End(xlUp).Row
If Cells(sRow, "A") Like "*apples*" Then
sCount = sCount + 1
dRow = dRow + 1
'copy cols A,F,E & D
Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
<o> </o>
End If
Next sRow

MsgBox sCount & "Significant rows copied", vbInformation, "Transfer Done"
<o> </o>
End Sub
Sub banana ()
<o> </o>
With Sheets("Sheet1").Select
End With
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1
<o> </o>
For sRow = 1 To Range(" A65536").End(xlUp).Row
If Cells(sRow, "A") Like "* banana *" Then
sCount = sCount + 1
dRow = dRow + 1

Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
<o> </o>
End If
Next sRow

MsgBox sCount & "Significant rows copied", vbInformation, "Transfer Done"
<o> </o>
End Sub
<o> </o>
Sub oranges()
<o> </o>
<o> </o>
With Sheets("Sheet1").Select
End With
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1
<o> </o>
For sRow = 1 To Range(" A65536").End(xlUp).Row
If Cells(sRow, "A") Like "*oranges*" Then
sCount = sCount + 1
dRow = dRow + 1
'copy cols A,F,E & D
Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
<o> </o>
End If
Next sRow

MsgBox sCount & " Significant rows copied", vbInformation, "Transfer Done"
<o> </o>
End Sub
Sub grapefruit()
<o> </o>
With Sheets("Sheet1").Select
End With
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1
<o> </o>
For sRow = 1 To Range(" A65536").End(xlUp).Row
If Cells(sRow, "A") Like "*grapefruit*" Then
sCount = sCount + 1
dRow = dRow + 1

Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
<o> </o>
End If
Next sRow

MsgBox sCount & " Significant rows copied", vbInformation, "Transfer Done"
<o> </o>
End Sub
<o> </o>
End Sub
Sub Runall()
Call apple
Call orange
Call grapefruit
Call banana

End Sub
<o> </o>
<o> </o>
<o> </o>
<o> </o>

 

[Case_Germany]

Hi,

try the following code:

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub Test()
    Dim wksSheetQ As Worksheet
    Dim wksSheetZ As Worksheet
    Dim strAddress As String
    Dim rngSearch As Range
    Dim varArr As Variant
    Dim lngTime1 As Long
    Dim lngTime2 As Long
    Dim lngTMP As Long
    On Error GoTo Fin
    lngTime1 = GetTickCount
    Set wksSheetQ = ThisWorkbook.Worksheets(1)
    Application.ScreenUpdating = False
    varArr = Array("apple", "banana", "oranges", "grapefruit")
    For lngTMP = 0 To UBound(varArr)
        Set wksSheetZ = Worksheets.Add
        ActiveSheet.Name = varArr(lngTMP)
        With wksSheetQ.Range("A:A")
            Set rngSearch = .Find(varArr(lngTMP), LookAt:=xlPart, LookIn:=xlValues)
            If Not rngSearch Is Nothing Then
                strAddress = rngSearch.Address
                Do
                    'wksSheetQ.Cells(rngSearch.Row, 1).Copy wksSheetZ.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                    wksSheetZ.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = wksSheetQ.Cells(rngSearch.Row, 1).Value
                    Set rngSearch = .FindNext(rngSearch)
                Loop Until rngSearch Is Nothing Or rngSearch.Address = strAddress
            End If
        End With
    Next
Fin:
    Application.ScreenUpdating = True
    lngTime2 = GetTickCount
    MsgBox (lngTime2 - lngTime1) / 1000
End Sub

If you do not need the formats, then it is better not with copy to work. With 30.000 lines the code needs 8 seconds. With copying 40 seconds. Therefore I out-commentated this line.

Case_Germany

 

[Case_Germany]

Hi,

with 30.000 lines and an array construct instead of loop through the cells the code needs 3 seconds:

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub Test()
    Dim wksSheetQ As Worksheet
    Dim wksSheetZ As Worksheet
    Dim strAddress As String
    Dim varArr1() As Variant
    Dim rngSearch As Range
    Dim varArr As Variant
    Dim lngTime1 As Long
    Dim lngTime2 As Long
    Dim lngCount As Long
    Dim lngTMP As Long
    On Error GoTo Fin
    lngTime1 = GetTickCount
    Set wksSheetQ = ThisWorkbook.Worksheets(1)
    Application.ScreenUpdating = False
    varArr = Array("apple", "banana", "oranges", "grapefruit")
    For lngTMP = 0 To UBound(varArr)
        Set wksSheetZ = Worksheets.Add
        ActiveSheet.Name = varArr(lngTMP)
        With wksSheetQ.Range("A:A")
            Set rngSearch = .Find(varArr(lngTMP), LookAt:=xlPart, LookIn:=xlValues)
            If Not rngSearch Is Nothing Then
                strAddress = rngSearch.Address
                Do
                    ReDim Preserve varArr1(lngCount)
                    varArr1(lngCount) = wksSheetQ.Cells(rngSearch.Row, 1).Value
                    lngCount = lngCount + 1
                    Set rngSearch = .FindNext(rngSearch)
                Loop Until rngSearch Is Nothing Or rngSearch.Address = strAddress
                With wksSheetZ
                    varArr1 = Application.WorksheetFunction.Transpose(varArr1)
                    .Range("A1:A" & UBound(varArr1)).Value = varArr1
                End With
                lngCount = 0
                ReDim varArr1(lngCount)
            End If
        End With
    Next
Fin:
    Application.ScreenUpdating = True
    lngTime2 = GetTickCount
    MsgBox (lngTime2 - lngTime1) / 1000
End Sub

That can be done surely somehow still faster.

Case_Germany

 

[mlglover]

Hello Case,

Your help has been greatly appreciated. The macro that you had helped with works beautifully. I have tried to modify it to work elsewhere and I am not having any luck. The new report contains data in columns “A” through “U”. What I have changed from the original is this:
Set wksSheetQ = ThisWorkbook.Worksheets(2) to (1) because the new data is on sheet one.
With wksSheetQ.Range(“A:A”) to (“B:B”) because that is were the search data is located.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
In the original macro all of the data was in (A:A) now it is in columns A through U and I need the complete row copied to the appropriate newly created sheet. So far I can get the new sheets created and named and at one point I was able to get column A to paste into the appropriate new sheets.
<o> </o>
Again Thank you for your time and assistance.
Michael