+ Reply to Thread
Results 1 to 4 of 4

Need a slight modification to code

  1. #1
    Dean
    Guest

    Need a slight modification to code

    I am having an issue with the code below (bit beyond my skills, sorry)

    While the code below is doing what it was designed to do (copy findings
    to another sheet) the problem I am having is when I do a second search
    of the "database" sheet the original search findings are removed or
    overwritten on the "Found" sheet.

    I would appreciate any ideas on how to stop further searches from
    overwriting the original findings and simply add them on to the end of
    the first search results. (hope this makes sense)

    Thanks,

    Dean


    Public Sub vbaCopyToAnotherSheetRealQuickLike()
    Dim rCell As Excel.Range
    Dim rRow As Excel.Range
    Dim wksFound As Excel.Worksheet
    Dim wksData As Excel.Worksheet

    Dim szLookupVal As String
    Dim szRowAddy As String

    Dim lRow As Long


    Set wksFound = Sheets("Found") 'Sheet that gets the copied data
    Set wksData = Sheets("Database") 'Sheet that contains the data to
    search


    lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row

    szLookupVal = InputBox("What are you searching for", "Search-Box",
    "")
    If Len(szLookupVal) = 0 Then Exit Sub

    With wksData.Cells

    Set rCell = .Find(szLookupVal, , , , , , False)
    If Not rCell Is Nothing Then

    szRowAddy = rCell.Address

    Set rRow = rCell

    Do

    Set rCell = .FindNext(rCell)

    Set rRow = Application.Union(rRow, rCell)

    rRow.EntireRow.Copy wksFound.Cells(lRow, 1)

    Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy

    End If
    End With

    Set rCell = Nothing
    Set rRow = Nothing
    Set wksFound = Nothing
    Set wksData = Nothing
    End Sub


  2. #2
    Bob Phillips
    Guest

    Re: Need a slight modification to code

    Try changing this line

    lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row

    to

    lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row + 1


    --
    HTH

    Bob Phillips

    (remove nothere from email address if mailing direct)

    "Dean" <[email protected]> wrote in message
    news:[email protected]...
    > I am having an issue with the code below (bit beyond my skills, sorry)
    >
    > While the code below is doing what it was designed to do (copy findings
    > to another sheet) the problem I am having is when I do a second search
    > of the "database" sheet the original search findings are removed or
    > overwritten on the "Found" sheet.
    >
    > I would appreciate any ideas on how to stop further searches from
    > overwriting the original findings and simply add them on to the end of
    > the first search results. (hope this makes sense)
    >
    > Thanks,
    >
    > Dean
    >
    >
    > Public Sub vbaCopyToAnotherSheetRealQuickLike()
    > Dim rCell As Excel.Range
    > Dim rRow As Excel.Range
    > Dim wksFound As Excel.Worksheet
    > Dim wksData As Excel.Worksheet
    >
    > Dim szLookupVal As String
    > Dim szRowAddy As String
    >
    > Dim lRow As Long
    >
    >
    > Set wksFound = Sheets("Found") 'Sheet that gets the copied data
    > Set wksData = Sheets("Database") 'Sheet that contains the data to
    > search
    >
    >
    > lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row
    >
    > szLookupVal = InputBox("What are you searching for", "Search-Box",
    > "")
    > If Len(szLookupVal) = 0 Then Exit Sub
    >
    > With wksData.Cells
    >
    > Set rCell = .Find(szLookupVal, , , , , , False)
    > If Not rCell Is Nothing Then
    >
    > szRowAddy = rCell.Address
    >
    > Set rRow = rCell
    >
    > Do
    >
    > Set rCell = .FindNext(rCell)
    >
    > Set rRow = Application.Union(rRow, rCell)
    >
    > rRow.EntireRow.Copy wksFound.Cells(lRow, 1)
    >
    > Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy
    >
    > End If
    > End With
    >
    > Set rCell = Nothing
    > Set rRow = Nothing
    > Set wksFound = Nothing
    > Set wksData = Nothing
    > End Sub
    >




  3. #3
    Dean
    Guest

    Re: Need a slight modification to code

    Thanks Bob, worked a treat.

    Dean


  4. #4
    Bob Phillips
    Guest

    Re: Need a slight modification to code

    Just noticed something else

    Public Sub vbaCopyToAnotherSheetRealQuickLike()
    Dim rCell As Excel.Range
    Dim rRow As Excel.Range
    Dim wksFound As Excel.Worksheet
    Dim wksData As Excel.Worksheet

    Dim szLookupVal As String
    Dim szRowAddy As String

    Dim lRow As Long

    Set wksFound = Sheets("Found") 'Sheet that gets the copied data
    Set wksData = Sheets("Database") 'Sheet that contains the data to search

    lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row
    szLookupVal = InputBox("What are you searching for", "Search-Box",
    "")
    If Len(szLookupVal) = 0 Then Exit Sub

    With wksData.Cells

    Set rCell = .Find(szLookupVal, , , , , , False)
    If Not rCell Is Nothing Then

    szRowAddy = rCell.Address

    Set rRow = rCell

    Do

    Set rCell = .FindNext(rCell)

    Set rRow = Application.Union(rRow, rCell)

    lRow = lRow + 1

    rRow.EntireRow.Copy wksFound.Cells(lRow, 1)

    Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy

    End If
    End With

    Set rCell = Nothing
    Set rRow = Nothing
    Set wksFound = Nothing
    Set wksData = Nothing
    End Sub

    --
    HTH

    Bob Phillips

    (remove nothere from email address if mailing direct)

    "Bob Phillips" <[email protected]> wrote in message
    news:OfK%[email protected]...
    > Try changing this line
    >
    > lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row
    >
    > to
    >
    > lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row + 1
    >
    >
    > --
    > HTH
    >
    > Bob Phillips
    >
    > (remove nothere from email address if mailing direct)
    >
    > "Dean" <[email protected]> wrote in message
    > news:[email protected]...
    > > I am having an issue with the code below (bit beyond my skills, sorry)
    > >
    > > While the code below is doing what it was designed to do (copy findings
    > > to another sheet) the problem I am having is when I do a second search
    > > of the "database" sheet the original search findings are removed or
    > > overwritten on the "Found" sheet.
    > >
    > > I would appreciate any ideas on how to stop further searches from
    > > overwriting the original findings and simply add them on to the end of
    > > the first search results. (hope this makes sense)
    > >
    > > Thanks,
    > >
    > > Dean
    > >
    > >
    > > Public Sub vbaCopyToAnotherSheetRealQuickLike()
    > > Dim rCell As Excel.Range
    > > Dim rRow As Excel.Range
    > > Dim wksFound As Excel.Worksheet
    > > Dim wksData As Excel.Worksheet
    > >
    > > Dim szLookupVal As String
    > > Dim szRowAddy As String
    > >
    > > Dim lRow As Long
    > >
    > >
    > > Set wksFound = Sheets("Found") 'Sheet that gets the copied data
    > > Set wksData = Sheets("Database") 'Sheet that contains the data to
    > > search
    > >
    > >
    > > lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row
    > >
    > > szLookupVal = InputBox("What are you searching for", "Search-Box",
    > > "")
    > > If Len(szLookupVal) = 0 Then Exit Sub
    > >
    > > With wksData.Cells
    > >
    > > Set rCell = .Find(szLookupVal, , , , , , False)
    > > If Not rCell Is Nothing Then
    > >
    > > szRowAddy = rCell.Address
    > >
    > > Set rRow = rCell
    > >
    > > Do
    > >
    > > Set rCell = .FindNext(rCell)
    > >
    > > Set rRow = Application.Union(rRow, rCell)
    > >
    > > rRow.EntireRow.Copy wksFound.Cells(lRow, 1)
    > >
    > > Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy
    > >
    > > End If
    > > End With
    > >
    > > Set rCell = Nothing
    > > Set rRow = Nothing
    > > Set wksFound = Nothing
    > > Set wksData = Nothing
    > > End Sub
    > >

    >
    >




+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1