Wrox Programmer Forums

Need to download code?

View our list of code downloads.

Go Back   Wrox Programmer Forums > Microsoft Office > Excel VBA > Excel VBA
Password Reminder
Register
| FAQ | Members List | Calendar | Search | Today's Posts | Mark Forums Read
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 tens of thousands of software programmers and website developers including Wrox book authors and readers. As a guest, you can read any forum posting. By joining today you can post your own programming questions, respond to other developers’ questions, and eliminate the ads that are displayed to guests. Registration is fast, simple and absolutely free .
DRM-free e-books 300x50
Reply
 
Thread Tools Search this Thread Display Modes
  #1 (permalink)  
Old December 5th, 2006, 08:58 PM
Authorized User
Points: 336, Level: 6
Points: 336, Level: 6 Points: 336, Level: 6 Points: 336, Level: 6
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Sep 2006
Location: , , .
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

Reply With Quote
  #2 (permalink)  
Old December 6th, 2006, 05:29 AM
Friend of Wrox
 
Join Date: Jun 2003
Location: London, , United Kingdom.
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
Reply With Quote
  #3 (permalink)  
Old December 6th, 2006, 12:20 PM
Authorized User
Points: 336, Level: 6
Points: 336, Level: 6 Points: 336, Level: 6 Points: 336, Level: 6
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Sep 2006
Location: , , .
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

Reply With Quote
  #4 (permalink)  
Old December 6th, 2006, 12:30 PM
Friend of Wrox
 
Join Date: Jun 2003
Location: London, , United Kingdom.
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

Reply With Quote
  #5 (permalink)  
Old December 6th, 2006, 12:32 PM
Friend of Wrox
 
Join Date: Jun 2003
Location: London, , United Kingdom.
Posts: 173
Thanks: 0
Thanked 3 Times in 3 Posts
Default

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

Reply With Quote
  #6 (permalink)  
Old December 6th, 2006, 12:44 PM
Authorized User
Points: 336, Level: 6
Points: 336, Level: 6 Points: 336, Level: 6 Points: 336, Level: 6
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Sep 2006
Location: , , .
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


Reply With Quote
  #7 (permalink)  
Old December 6th, 2006, 12:51 PM
Authorized User
Points: 336, Level: 6
Points: 336, Level: 6 Points: 336, Level: 6 Points: 336, Level: 6
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Sep 2006
Location: , , .
Posts: 73
Thanks: 6
Thanked 0 Times in 0 Posts
Default

I believe I figured it out.. Thanks again.

Reply With Quote
  #8 (permalink)  
Old December 21st, 2006, 10:23 AM
Registered User
 
Join Date: Dec 2006
Location: , , .
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.

Reply With Quote
Reply


Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is Off
HTML code is Off
Trackbacks are Off
Pingbacks are On
Refbacks are Off


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



All times are GMT -4. The time now is 06:53 PM.


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