Wrox Programmer Forums
Go Back   Wrox Programmer Forums > Microsoft Office > Excel VBA > Excel VBA
|
Excel VBA Discuss using VBA for Excel programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Excel VBA section of the Wrox Programmer to Programmer discussions. This is a community of software programmers and website developers including Wrox book authors and readers. New member registration was closed in 2019. New posts were shut off and the site was archived into this static format as of October 1, 2020. If you require technical support for a Wrox book please contact http://hub.wiley.com
 
Old December 5th, 2006, 08:58 PM
Authorized User
 
Join Date: Sep 2006
Posts: 73
Thanks: 6
Thanked 0 Times in 0 Posts
Default Copying Rows to New worksheet

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

 
Old December 6th, 2006, 05:29 AM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 173
Thanks: 0
Thanked 3 Times in 3 Posts
Default

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
 
Old December 6th, 2006, 12:20 PM
Authorized User
 
Join Date: Sep 2006
Posts: 73
Thanks: 6
Thanked 0 Times in 0 Posts
Default

Thanks Maccas..

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


Thanks again,
Tony

 
Old December 6th, 2006, 12:30 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 173
Thanks: 0
Thanked 3 Times in 3 Posts
Default

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

 
Old December 6th, 2006, 12:32 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 173
Thanks: 0
Thanked 3 Times in 3 Posts
Default

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

 
Old December 6th, 2006, 12:44 PM
Authorized User
 
Join Date: Sep 2006
Posts: 73
Thanks: 6
Thanked 0 Times in 0 Posts
Default

Thanks again for your help.

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

Tony


 
Old December 6th, 2006, 12:51 PM
Authorized User
 
Join Date: Sep 2006
Posts: 73
Thanks: 6
Thanked 0 Times in 0 Posts
Default

I believe I figured it out.. Thanks again.

 
Old December 21st, 2006, 10:23 AM
Registered User
 
Join Date: Dec 2006
Posts: 1
Thanks: 0
Thanked 0 Times in 0 Posts
Default

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.






Similar Threads
Thread Thread Starter Forum Replies Last Post
Counting rows in Excel worksheet Tethys BOOK: Access 2003 VBA Programmer's Reference 1 December 18th, 2007 04:38 AM
copying input data to another worksheet with code kwik10z Excel VBA 3 November 2nd, 2007 01:45 PM
Copying Multiple Rows raj_phoenix Excel VBA 3 May 6th, 2005 03:58 AM
Copying Multiple Rows in MS Excel 2K using VB .Net Azhar Akbari Excel VBA 2 January 27th, 2005 10:04 AM





Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright (c) 2020 John Wiley & Sons, Inc.