none
search for match RRS feed

  • Question

  • I have taken over some VBA code.

    The current code has one Excel 2003 workbook which opens a second Excel 2003 workbook.

    The goal is to find the row where columnB = "search1" and columnC = "search2"

    I stop searching when columnA cell is empty/blank.

    The Excel locks up.

    Is there a more efficient way to do this?

     Private Sub Test()

    Dim columnA As String Dim filepath As String Dim i As Long filepath = "C:\DatasheetGenerator\Measurements.xls" If Not IsFileOpen(filepath) Then 'open file as readOnly Workbooks.OpenText filepath, , , xlDelimited, , , True Else MsgBox "data file is open." Exit Sub End If columnA = "columnA" i = 859 'start at row 859 Do While (Len(columnA) > 0) 'keep looping as long as columnA is not empty columnA = Worksheets("data").Range("A" & i).Value

    'put code here to look at columnB and columnC

    Loop MsgBox "i=" & i End Sub


    Thursday, April 21, 2016 2:59 PM

Answers

All replies

  • Option Explicit
    
    Sub Main()
      Dim filepath As String
      Dim Wb As Workbook
      Dim Where As Range, All As Range
    
      filepath = "C:\DatasheetGenerator\Measurements.xls"
      
      Set Wb = GetWorkBook(filepath)
      If Wb Is Nothing Then Set Wb = Workbooks.Open(filepath)
    
      Set Where = Wb.Worksheets(1).Range("B:B")
      Set All = FindAll(Where, "search1")
      If All Is Nothing Then
        MsgBox "Not found"
        Exit Sub
      End If
      
      Set Where = Wb.Worksheets(1).Range("C:C")
      Set Where = Intersect(Where, All.EntireRow)
      
      Set All = FindAll(Where, "search2")
      If All Is Nothing Then
        MsgBox "Not found"
        Exit Sub
      End If
      
      MsgBox "Found at " & All.Address(0, 0)
    End Sub
    
    Private Function GetWorkBook(ByVal WorkBookName As String) As Workbook
      'Return the workbook that name is like WorkBookName, Nothing if not open
      Dim fso As Object 'FileSystemObject
      Set fso = CreateObject("Scripting.FileSystemObject")
      'Path given?
      If Len(fso.GetParentFolderName(WorkBookName)) > 0 Then
        'Compare the full path of each open workbook
        For Each GetWorkBook In Workbooks
          If StrComp(GetWorkBook.FullName, WorkBookName, vbTextCompare) = 0 Then
            Exit Function
          End If
        Next
      ElseIf InStrRev(WorkBookName, ".") > 0 Then
        'We must exact match if an extension is given
        On Error GoTo ExitPoint
        Set GetWorkBook = Workbooks(WorkBookName)
      Else
        'Without an extension it can be a new file too
        On Error GoTo SearchIt
        Set GetWorkBook = Workbooks(WorkBookName)
        Exit Function
    SearchIt:
        On Error GoTo ExitPoint
        If (InStr(WorkBookName, "?") > 0) Or (InStr(WorkBookName, "*") > 0) Then
          For Each GetWorkBook In Workbooks
            If fso.GetBaseName(GetWorkBook.Name) Like WorkBookName Then
              Exit Function
            End If
          Next
        Else
          For Each GetWorkBook In Workbooks
            If StrComp(fso.GetBaseName(GetWorkBook.Name), WorkBookName, vbTextCompare) = 0 Then
              Exit Function
            End If
          Next
        End If
      End If
    ExitPoint:
    End Function
    
    Private Function FindAll(ByVal Where As Range, ByVal What, _
        Optional ByVal After As Variant, _
        Optional ByVal LookIn As XlFindLookIn = xlValues, _
        Optional ByVal LookAt As XlLookAt = xlWhole, _
        Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
        Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
        Optional ByVal MatchCase As Boolean = False, _
        Optional ByVal SearchFormat As Boolean = False) As Range
      'Find all occurrences of What in Where (Windows version)
      Dim FirstAddress As String
      Dim c As Range
      'From FastUnion:
      Dim Stack As New Collection
      Dim Temp() As Range, Item
      Dim i As Long, j As Long
    
      If Where Is Nothing Then Exit Function
      If SearchDirection = xlNext And IsMissing(After) Then
        'Set After to the last cell in Where to return the first cell in Where in front if _
          it match What
        Set c = Where.Areas(Where.Areas.Count)
        'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
        'Set After = C.Cells(C.Cells.Count)
        Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
      End If
    
      Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
        SearchDirection, MatchCase, SearchFormat:=SearchFormat)
      If c Is Nothing Then Exit Function
    
      FirstAddress = c.Address
      Do
        Stack.Add c
        If SearchFormat Then
          'If you call this function from an UDF and _
            you find only the first cell use this instead
          Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _
            SearchDirection, MatchCase, SearchFormat:=SearchFormat)
        Else
          If SearchDirection = xlNext Then
            Set c = Where.FindNext(c)
          Else
            Set c = Where.FindPrevious(c)
          End If
        End If
        'Can happen if we have merged cells
        If c Is Nothing Then Exit Do
      Loop Until FirstAddress = c.Address
    
      'FastUnion algorithm © Andreas Killer, 2011:
      'Get all cells as fragments
      ReDim Temp(0 To Stack.Count - 1)
      i = 0
      For Each Item In Stack
        Set Temp(i) = Item
        i = i + 1
      Next
      'Combine each fragment with the next one
      j = 1
      Do
        For i = 0 To UBound(Temp) - j Step j * 2
          Set Temp(i) = Union(Temp(i), Temp(i + j))
        Next
        j = j * 2
      Loop Until j > UBound(Temp)
      'At this point we have all cells in the first fragment
      Set FindAll = Temp(0)
    End Function
    

    Thursday, April 21, 2016 3:35 PM
  • Hi IntenseNJ

    I think Andreas Killer's suggestion can be your answer. please check it.

    Regards

    Deepak


    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.

    Friday, April 22, 2016 1:35 AM
    Moderator
  • I ended up using Range.Find( )

    I did not need the complexity of Andreas Killer's code.

    Monday, April 25, 2016 7:54 PM
  • Hi IntenseNJ,

    is your issue solved by using Range.Find( ).

    if it is solved would you like to share the solution so that other community member that have the same problem can also get solution from your post.

    Regards

    Deepak


    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, April 26, 2016 3:21 AM
    Moderator