Copying Rows to New worksheet

eusanpe · December 5th, 2006, 08:58 PM

I am trying to copy certain rows that contain the word "suspension" and "oral" to another worksheet. I can't get it to work. It just hangs. Here is the data.
===============================================
20 mg tablet 3 times a day^isosorbide dinitrate
200 mg tablet every other day^voriconazole
500 mg tablet^cefuroxime
___ mg^phenazopyridine suspension Mott
325 mg tablet 3 times a day with meals^ferrous sulfate
180 mg tablet daily^fexofenadine
oral^aripiprazole solution Mott
___ mg^doxycycline syrup
___mg^enalapril solution Mott
0.05 mg tablet^pergolide
1 mg tablet^pergolide
15 mg tablet^phenelzine
30 mg tablet^phenobarbital
2 mg/mL suspension, oral^paroxetine
37.5 mg tablet^pemoline
solution, oral (dose < 800 units)^ergocalciferol
===========================================
Here is what I have:

Sub OralSuspensionFinder()
Dim ws As Object

'Turn off screen updating to increase performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

'Select "A" Column
    Columns("A:A").Select

'Find data
    Dim rng0 As Range
    Dim rng1 As Range
    Dim what0 As String
    Dim what1 As String

    what0 = "oral"
    what1 = "suspension"

    Do
        Set rng0 = ActiveSheet.UsedRange.Find(what0)
        If rng0 Is Nothing Then
            Exit Do
        Else
            Sheets("Sheet1").Select
            Rows(rng0.Row).EntireRow.Select
            Selection.Copy
            Sheets("Sheet2").Paste
            ActiveSheet.Paste
        End If
    Loop

Do
        Set rng1 = ActiveSheet.UsedRange.Find(what1)
        If rng1 Is Nothing Then
            Exit Do
        Else
            Sheets("Sheet1").Select
            Rows(rng1.Row).EntireRow.Select
            Selection.Copy
            Sheets("Sheet2").Paste
            ActiveSheet.Paste
        End If
    Loop

'Turn screen updating back on
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

================================================== =====
Can anyone help? Thanks...

Tony

maccas · December 6th, 2006, 05:29 AM

Tony,

It was probably hanging because you were never exiting your Do loops - due to re-finding the same cells over and over. The following bit of code uses the FindNext method and checks to see if we've re-found the first cell. These two criteria should be sufficient to quit the loops satisfactorily:

Code:

Sub OralSuspensionFinder()

Dim wksSearch As Worksheet
Dim wksOut As Worksheet
Dim intOutRow As Integer

Dim rngFound As Range
Dim strWhat As String
Dim strFirstAddress As String

    ' Turn off screen updating to increase performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set wksSearch = ThisWorkbook.Sheets("Sheet2")
    Set wksOut = ThisWorkbook.Sheets("Sheet3")
    intOutRow = 2

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Find the word oral
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    strWhat = "oral"

    ' Add a heading
    wksOut.Cells(intOutRow, 1).Value = strWhat
    wksOut.Cells(intOutRow, 1).Font.Bold = True
    intOutRow = intOutRow + 1

    Set rngFound = wksSearch.UsedRange.Find(strWhat)

    ' If we've found something then proceed
    If Not rngFound Is Nothing Then

        ' Record the first found address
        strFirstAddress = rngFound.Address

        ' Loop until we find no more or get back to the first found instance
        Do

            ' Copy across the values of the row
            wksOut.Cells(intOutRow, 1).EntireRow.Value = rngFound.EntireRow.Value

            ' Increment the ourput row counter
            intOutRow = intOutRow + 1

            ' Find the next instance
            Set rngFound = wksSearch.UsedRange.FindNext(rngFound)

        Loop Until rngFound Is Nothing Or rngFound.Address = strFirstAddress

    End If

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Find the word suspension
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    strWhat = "suspension"

    ' Add a heading
    wksOut.Cells(intOutRow, 1).Value = strWhat
    wksOut.Cells(intOutRow, 1).Font.Bold = True
    intOutRow = intOutRow + 1

    Set rngFound = wksSearch.UsedRange.Find(strWhat)

    ' If we've found something then proceed
    If Not rngFound Is Nothing Then

        ' Record the first found address
        strFirstAddress = rngFound.Address

        ' Loop until we find no more or get back to the first found instance
        Do

            ' Copy across the values of the row
            wksOut.Cells(intOutRow, 1).EntireRow.Value = rngFound.EntireRow.Value

            ' Increment the ourput row counter
            intOutRow = intOutRow + 1

            ' Find the next instance
            Set rngFound = wksSearch.UsedRange.FindNext(rngFound)

        Loop Until rngFound Is Nothing Or rngFound.Address = strFirstAddress

    End If

    'Turn screen updating back on
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

eusanpe · December 6th, 2006, 12:20 PM

Thanks Maccas..

This works great except that the search should only be in Column A. Where do I make the change?

Thanks again,
Tony

maccas · December 6th, 2006, 12:30 PM

Well in that case rather than

Code:

wksSearch.UsedRange.Find(strWhat)

use

[code]wksSearch.Columns(1).Find(strWhat)code]

The same change applies to the FindNext methods

Maccas

maccas · December 6th, 2006, 12:32 PM

oops - The code identifier got garbled. Hopefully you can read what I mean.

eusanpe · December 6th, 2006, 12:44 PM

Thanks again for your help.

What it is doing is only printing 'oral' and 'suspension' once when there are numerous of them.

Tony

eusanpe · December 6th, 2006, 12:51 PM

I believe I figured it out.. Thanks again.

capecodder · December 21st, 2006, 10:23 AM

Can I use this solution to select non-contiguous rows in a sheet based on a "Greater than" expression and copy them to another sheet?

Thanks.