none
How to search all cells for a value and if found, copy row and two rows above to a new sheet? RRS feed

  • Question

  • I'm trying to loop through a whole bunch of cells, one cell at a time, and look for a specific value '#DIV/0!' and if found (it could be in any Column, from E:N) then copy that row plus two rows above that cell, to a new sheet.  On the new sheet, I need to check for the last used row, and paste the results into the next available unused row.

    Here's the code that I'm working with.  It's not really doing what I want to do.  Any suggestions, anyone?

    Sub customcopy()
    Dim strsearch As String, lastline As Integer, tocopy As Integer
    
    strsearch = "#DIV/0!"
    lastline = Range("A65536").End(xlUp).Row
    j = 1
    
    For i = 1 To lastline
        For Each c In Range("B" & i & ":N" & i)
            If InStr(c.Text, strsearch) Then
                tocopy = 1
            End If
        Next c
        If tocopy = 1 Then
            Rows(i).Select
                With Worksheets("sheet1").Range("a1")
                    .End(xlDown).Copy Destination:=Worksheets("CopyHere").Range("A1")
                End With
            j = j + 1
        End If
    tocopy = 0
    Next i
    
    End Sub
    Thanks!!!



    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Saturday, January 30, 2016 4:54 AM

Answers

  • Option Explicit
    
    Private Sub Setup()
      'Create a static test scenario
      With Range("E1:N25")
        .Formula = "=IF(RAND()>0.97,1/0,ADDRESS(ROW(),COLUMN()))"
        .Value = .Value
      End With
    End Sub
    
    Sub Main()
      Dim ErrF As Range, ErrC As Range
      Dim All As Range, R As Range, Result As Range, Dest As Range
      'refer to the data cells
      Set All = Intersect(Range("E3").CurrentRegion, Columns("E:N"))
      
      If All.Row < 3 Then
        'Skip the top 2 cells (we should copy #DIV and 2 rows abvove)
        Set All = All.Offset(2).Resize(All.Rows.Count - 2)
      End If
      'Find the cells with an error
      Set ErrF = SpecialCells(All, xlCellTypeFormulas, xlErrors)
      Set ErrC = SpecialCells(All, xlCellTypeConstants, xlErrors)
      'Combine them
      If ErrF Is Nothing Then
        Set All = ErrC
      ElseIf ErrC Is Nothing Then
        Set All = ErrF
      Else
        Set All = Union(ErrC, ErrF)
      End If
      
      'Found?
      If All Is Nothing Then Exit Sub
      'Get the rows
      Set All = Intersect(All.EntireRow, Columns("E:N"))
      
      'Find the rows to copy
      For Each R In All.Rows
        Set R = R.Offset(-2).Resize(3)
        If Result Is Nothing Then
          Set Result = R
        Else
          Set Result = Union(Result, R)
        End If
      Next
      
      'Copy to the other sheet
      Set Dest = Worksheets("CopyHere").Range("A" & Rows.Count).End(xlUp).Offset(1)
      Result.Copy Dest
    End Sub
    
    Private Function SpecialCells(ByVal R As Range, ByVal Typ As XlCellType, _
        Optional ByVal Value As XlSpecialCellsValue = &H17) As Range
      'Avoid the SpecialCells-BUG to return all cells from the current region
      On Error Resume Next
      Select Case Typ
        Case xlCellTypeConstants, xlCellTypeFormulas
          Set SpecialCells = Intersect(R, R.SpecialCells(Typ, Value))
        Case Else
          Set SpecialCells = Intersect(R, R.SpecialCells(Typ))
      End Select
    End Function
    

    • Marked as answer by ryguy72 Saturday, January 30, 2016 2:33 PM
    Saturday, January 30, 2016 9:51 AM
  • you want #DIV/0! Items, I think you could only use code below:
    Set ErrC = SpecialCells(All, xlCellTypeConstants, xlErrors)

    No, you'll miss cells with formulas like =A1/B1 when B1 is 0 or empty.

    Andreas.

    • Marked as answer by ryguy72 Tuesday, February 2, 2016 4:33 PM
    Monday, February 1, 2016 8:14 AM

All replies

  • Option Explicit
    
    Private Sub Setup()
      'Create a static test scenario
      With Range("E1:N25")
        .Formula = "=IF(RAND()>0.97,1/0,ADDRESS(ROW(),COLUMN()))"
        .Value = .Value
      End With
    End Sub
    
    Sub Main()
      Dim ErrF As Range, ErrC As Range
      Dim All As Range, R As Range, Result As Range, Dest As Range
      'refer to the data cells
      Set All = Intersect(Range("E3").CurrentRegion, Columns("E:N"))
      
      If All.Row < 3 Then
        'Skip the top 2 cells (we should copy #DIV and 2 rows abvove)
        Set All = All.Offset(2).Resize(All.Rows.Count - 2)
      End If
      'Find the cells with an error
      Set ErrF = SpecialCells(All, xlCellTypeFormulas, xlErrors)
      Set ErrC = SpecialCells(All, xlCellTypeConstants, xlErrors)
      'Combine them
      If ErrF Is Nothing Then
        Set All = ErrC
      ElseIf ErrC Is Nothing Then
        Set All = ErrF
      Else
        Set All = Union(ErrC, ErrF)
      End If
      
      'Found?
      If All Is Nothing Then Exit Sub
      'Get the rows
      Set All = Intersect(All.EntireRow, Columns("E:N"))
      
      'Find the rows to copy
      For Each R In All.Rows
        Set R = R.Offset(-2).Resize(3)
        If Result Is Nothing Then
          Set Result = R
        Else
          Set Result = Union(Result, R)
        End If
      Next
      
      'Copy to the other sheet
      Set Dest = Worksheets("CopyHere").Range("A" & Rows.Count).End(xlUp).Offset(1)
      Result.Copy Dest
    End Sub
    
    Private Function SpecialCells(ByVal R As Range, ByVal Typ As XlCellType, _
        Optional ByVal Value As XlSpecialCellsValue = &H17) As Range
      'Avoid the SpecialCells-BUG to return all cells from the current region
      On Error Resume Next
      Select Case Typ
        Case xlCellTypeConstants, xlCellTypeFormulas
          Set SpecialCells = Intersect(R, R.SpecialCells(Typ, Value))
        Case Else
          Set SpecialCells = Intersect(R, R.SpecialCells(Typ))
      End Select
    End Function
    

    • Marked as answer by ryguy72 Saturday, January 30, 2016 2:33 PM
    Saturday, January 30, 2016 9:51 AM
  • Wow!  Very Cool!  Thanks!!

    Just one question.  It seems like this grabs #VALUE! and #DIV/0!, both.  How can I change it to get one or the other?  All I really need is the #DIV/0! items.


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.


    • Edited by ryguy72 Saturday, January 30, 2016 2:32 PM
    Saturday, January 30, 2016 2:31 PM
  • Hi ryguy72,

    >> How can I change it to get one or the other?  All I really need is the #DIV/0! items.

    I think it is related with xlCellTypeFormulas and xlCellTypeConstants. xlCellTypeConstants is #DIV/0!. If you want #DIV/0! Items, I think you could only use code below:

    Set ErrC = SpecialCells(All, xlCellTypeConstants, xlErrors)

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.



    Monday, February 1, 2016 6:20 AM
  • you want #DIV/0! Items, I think you could only use code below:
    Set ErrC = SpecialCells(All, xlCellTypeConstants, xlErrors)

    No, you'll miss cells with formulas like =A1/B1 when B1 is 0 or empty.

    Andreas.

    • Marked as answer by ryguy72 Tuesday, February 2, 2016 4:33 PM
    Monday, February 1, 2016 8:14 AM
  • Hi Andreas,

    Yeah, you are right, thanks for suggestions.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Tuesday, February 2, 2016 3:17 AM
  • Yeah.  That works.  Thanks guys!!


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Tuesday, February 2, 2016 4:33 PM