To Find every instance of TEXT copy, repeat until no Find found

**DadaaP** · 07-25-2013, 12:05 PM

So here is what I need to have happen. Excuse me the code and excel file I have attached are seperate to prevent user data on the web I created the test file based from the Quickbooks data file I use for multiple excel macros.

I am trying to automate the process of creating a dynamic list based upon the test file attached. I want it to find every instance of the word "Bill Pmt -Check" in column B and copy the business name once it finds the word "Bill Pmt-Check" that is in column H of the same row. I would like it to continue until it cannot find another Bill Pmt-Check.

Here is what I have tried so far and I think it might be bad programming: ie I have it first searching for the number of instances of the word Bill Pmt -Check and recording that value in a cell. Then it stops copying business names once it hits that value of the cell aka the number of businesses it copies stops when it reaches the total NUMBER of businesses.'

This script is not working as it records the value 0 still:

Sub Macro1x()
'
' Macro1x Macro
'

'
    Dim inty As Integer
    inty = 2
    Worksheets("Sheet2").Activate
    Dim numofbus As Integer
    numofbus = 0
    


    'SHOULD RECORD HOW MANY INSTANCES OF EACH BUSINESS TO KNOW WHEN TO STOP COPYING BELOW
    Do While Cells.Find(What:="Bill Pmt -Check", After:=Sheet2.Cells(1, 1), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False) = True
        
        numofbus = numofbus + 1
        Loop
        
        Application.Wait (Now + TimeValue("0:00:01"))
    
    Cells(44, 1).Value = numofbus
    
    Cells.Find(What:="Bill Pmt -Check", After:=Sheet2.Cells(1, 1), LookIn:=xlValues, _
       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 6).Activate
        ActiveCell.Copy
        Sheets("Sheet1").Cells(1, 23).PasteSpecial xlPasteAll

        Set FoundCell = Worksheets("Sheet2").Cells.Find(What:="Bill Pmt -Check", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        'SHOULD COPY THE BUSINESS NAMES AND STOP WHEN IT RECEIVES HITS THE ROW NUMBER THAT IS THE SAME AS THE INTEGER SAVED AKA NUMBER OF BUSINESSES
        Do Until ActiveCell.Row = Cells(44, 1).Value
            Worksheets("Sheet2").Activate
            Cells.FindNext(After:=ActiveCell).Activate
            ActiveCell.Offset(0, 6).Activate
            ActiveCell.Copy
            Worksheets("Sheet1").Activate
            Sheets("Sheet1").Cells(inty, 23).Activate
            ActiveCell.PasteSpecial (xlPasteAll)
            inty = inty + 1
            Loop
            
        
        
End Sub

**tigeravatar** · 07-25-2013, 12:19 PM

DadaaP,

Give this a try:

Sub tgr()
    
    Const strWSData As String = "Sheet1"        'The name of the worksheet to search
    Const strFind As String = "Bill Pmt -Check" 'The text to find
    Const strTypeCol As String = "B"            'The column to search for the text
    Const strNameCol As String = "H"            'The column containing the return values
    
    Dim wsData As Worksheet
    Dim rngFound As Range
    Dim arrData() As String
    Dim strFirst As String
    Dim DataIndex As Long
    
    Set wsData = Sheets(strWSData)
    Set rngFound = wsData.Columns(strTypeCol).Find(strFind, Cells(Rows.Count, strTypeCol), xlValues, xlWhole)
    If Not rngFound Is Nothing Then
        ReDim arrData(1 To WorksheetFunction.CountIf(wsData.Columns(strTypeCol), strFind))
        strFirst = rngFound.Address
        Do
            DataIndex = DataIndex + 1
            arrData(DataIndex) = wsData.Cells(rngFound.Row, strNameCol).Text
            Set rngFound = wsData.Columns(strTypeCol).Find(strFind, rngFound, xlValues, xlWhole)
        Loop While rngFound.Address <> strFirst
    End If
    
    If DataIndex > 0 Then
        'Do something with the collected results here
        MsgBox Join(arrData, Chr(10))
        
        'To output them to a sheet, it would look something like this:
        'Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrData)).Value = Application.Transpose(arrData)
    End If
    
    Set wsData = Nothing
    Set rngFound = Nothing
    Erase arrData
    
End Sub

**DadaaP** · 07-25-2013, 01:34 PM

Have not used much in the way of arrays go. Thank you very very much for the code, I now understand how to use arrays.

Code works great and am editing the msg box to return a Yes or No prompt with the array whether the user agrees with the values that will be provided for the macro.

Thank you tigeravatar!!!!

**tigeravatar** · 07-25-2013, 02:15 PM

You're very welcome

To Find every instance of TEXT copy, repeat until no Find found

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

To Find every instance of TEXT copy, repeat until no Find found

Re: To Find every instance of TEXT copy, repeat until no Find found

Re: To Find every instance of TEXT copy, repeat until no Find found

Re: To Find every instance of TEXT copy, repeat until no Find found

Thread Information

Users Browsing this Thread

Similar Threads

Find matching text from sheet2 in sheet 1, if found copy contents of matching value row

[SOLVED] Macro to find text and if found, copy an adjacent cell into a different cell

[SOLVED] Find first and last instance of text in column range multiple times

Find&Copy only copying 1 instance of match

code to find, copy and paste until find new, then repeat

Bookmarks

Bookmarks

Posting Permissions