Searching Arrays without Loops?

ptmuldoon · #1 12-12-2014, 06:43 PM

I was able to put the below together, and it seems to work ok, but I think this could be more efficient with an array match of some sort. And still trying to learn more on that.

I would think maybe I could take an array of NamedRanges from Excel. And a 2nd Array of BookMarks from Word. Then compare/match the 2 arrays, placing the Matches into a new, third array, and then update my Word BookMarks with the values of the named ranges?

But I think i'm trying compare a 1 dimensional (bookmarks) to a 2 dimensional (NamedRange Name and Values)?

This code currently works. But can it be more efficient?

Code:

Sub Test()
    Dim f, xlWorkBook, NmdValue As Object
    Dim Bm, Nm As Variant
    Dim Bmk, NmdRng As String

    'Choose the Excel File
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Please Select A New File"
    f.AllowMultiSelect = False
    f.Filters.Clear
    f.Filters.Add "Microsoft Excel Files", "*.xls, *.xlsb, *.xlsm, *.xlsx" 'Limit to Excel Files Only

    If f.Show = -1 Then
        Set xlWorkBook = GetObject(f.SelectedItems(1))
    Else 'user clicked cancel
        Exit Sub
    End If
          
    For Each Bm In ActiveDocument.Bookmarks
        Bmk = Bm.Name
             
        ' Check Each BookMark for a Matching NamedRanged in the Excel File
        For Each Nm In xlWorkBook.Names
        NmdRng = Nm.Name
        Set NmdValue = xlWorkBook.Names(NmdRng).RefersToRange
        
             If Bmk = NmdRng Then
                ActiveDocument.Bookmarks(Bmk).Range.InsertAfter NmdValue
                'UpdateBM Bmk, NmdValue
                 Exit For
             End If
        Next Nm
        
    Next Bm
    
    ActiveDocument.Bookmarks.ShowHidden = True
    ActiveWindow.View.ShowBookmarks = False
    
End Sub


Sub UpdateBM(BookmarkToUpdate As String, TextToUse As String)
    Dim BMRange As Range
    Set BMRange = ActiveDocument.Bookmarks(BookmarkToUpdate).Range
    BMRange.Text = TextToUse
    ActiveDocument.Bookmarks.Add BookmarkToUpdate, BMRange
End Sub

ptmuldoon · #2 12-12-2014, 06:55 PM

And in continuing with the above, I have started in working to compare the 2 arrays and match. But again, I think my issue that I need the array of NamedRanges from Excel needs to be a 2 dimensional to someone pass the value of the cell vs its Name?

Currently, the arrays get matched and then returns the name of the bookmark/named range, when I trying to get the value of the namedranged.

The functions Array_UIntersect and IsInArray I did find elsewhere on the web, so can not take any credit for that work. Thanks to the those authors in helping me get this far.

Code:

Sub Test()
    Dim f, xlWorkBook  As Object
    Dim Bm, Nm, NmdValue, NmdRng, Bmk, MatchNames, Match As Variant
    Dim NewPath, MyText, ShtName, Test As String
    Dim i As Integer
    
    'Choose the Excel File
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Please Select A New File"
    f.AllowMultiSelect = False
    f.Filters.Clear
    f.Filters.Add "Microsoft Excel Files", "*.xls, *.xlsb, *.xlsm, *.xlsx" 'Limit to Excel Files Only

    If f.Show = -1 Then
        NewPath = f.SelectedItems(1)
        Set xlWorkBook = GetObject(f.SelectedItems(1))
    Else 'user clicked cancel
        Exit Sub
    End If

    'Create the Array of NamedRanges of Chosen File
    i = 1
    ReDim NmdRng(1 To 1)
    For Each Nm In xlWorkBook.Names
        Set NmdValue = xlWorkBook.Names(Nm.Name).RefersToRange
        ReDim Preserve NmdRng(i)
        NmdRng(i) = Nm.Name
        i = i + 1
    Next Nm
            
    'Create the Array of BookMarks
    i = 1
    ReDim Bmk(1 To 1)
    For Each Bm In ActiveDocument.Bookmarks
        ReDim Preserve Bmk(i)
        Bmk(i) = Bm.Name
        i = i + 1
    Next Bm
    
    'Create a New Array of Matched Values only
    MatchNames = Array_UIntersect(NmdRng, Bmk)
 
    ' Do Something with the Matches
    If UBound(MatchNames) > 0 Then
       For Each Match In MatchNames
            If Not IsEmpty(Match) Then
                MsgBox "Match was Found with: " & Match
                ActiveDocument.Bookmarks(Match).Range.InsertAfter Match
            End If
       Next Match
    End If
        
    ActiveDocument.Bookmarks.ShowHidden = True
    ActiveWindow.View.ShowBookmarks = False
    
End Sub

Function Array_UIntersect(array1 As Variant, array2 As Variant) As Variant
  Dim tempArray As Variant
  Dim i As Long
 
  ' start with a single element
  ReDim tempArray(0)
 
  ' if element in first array exists in second array, keep it
  For i = LBound(array1) To UBound(array1)
    If IsInArray(array2, array1(i)) Then  ' found!
      ReDim Preserve tempArray(UBound(tempArray) + 1)
      tempArray(UBound(tempArray)) = array1(i)
    End If
  Next i
 
  ' first element is Empty, so shift all elements one position up
  For i = LBound(tempArray) To UBound(tempArray) - 1
      tempArray(i) = tempArray(i + 1)
  Next i
  ' remove last element
  If UBound(tempArray) <> 0 Then
    ReDim Preserve tempArray(LBound(tempArray) To UBound(tempArray) - 1)
  End If
 
  Array_UIntersect = tempArray
End Function

Function IsInArray(arr As Variant, valueToCheck As Variant) As Boolean
   IsInArray = (UBound(Filter(arr, valueToCheck)) > -1)
End Function

macropod · #3 12-12-2014, 07:07 PM

Perhaps:

Code:

Sub Test()
    Dim f, xlWorkBook, NmdValue As Object
    Dim Bm, Nm As Variant
    Dim Bmk, NmdRng As String
    'Choose the Excel File
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Please Select A New File"
    f.AllowMultiSelect = False
    f.Filters.Clear
    f.Filters.Add "Microsoft Excel Files", "*.xls, *.xlsb, *.xlsm, *.xlsx" 'Limit to Excel Files Only
    If f.Show = -1 Then
        Set xlWorkBook = GetObject(f.SelectedItems(1))
    Else 'user clicked cancel
        Exit Sub
    End If
             
    ' Check Each NamedRanged in the Excel File for a Matching BookMark
    For Each Nm In xlWorkBook.Names
      NmdRng = Nm.Name
      If ActiveDocument.Bookmarks.Exists(NmdRng) = True Then
        Set NmdValue = xlWorkBook.Names(NmdRng).RefersToRange
        'Update the found bookmark
        ActiveDocument.Bookmarks(Bmk).Range.InsertAfter NmdValue
      End If
    Next
    ActiveDocument.Bookmarks.ShowHidden = True
    ActiveWindow.View.ShowBookmarks = False
End Sub
Sub UpdateBM(BookmarkToUpdate As String, TextToUse As String)
    Dim BMRange As Range
    Set BMRange = ActiveDocument.Bookmarks(BookmarkToUpdate).Range
    BMRange.Text = TextToUse
    ActiveDocument.Bookmarks.Add BookmarkToUpdate, BMRange
End Sub

ptmuldoon · #4 12-13-2014, 11:21 AM

Macropod, your unbelievable in the help and support you provide.

You simplified what was I attempting and also made it easier to understand. I continue to learn from all your help!!

Thank you so much!!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Filling cells with random numbers using loops? (VBA)	Sajj	Excel Programming	4	04-10-2013 02:29 PM
re-naming arrays in VBA?	JDevsFan	Excel Programming	4	03-15-2012 08:44 AM
HTML in email loops endlessly	rbtroj	Outlook	0	05-19-2011 12:29 PM
Powerpoint loops, but not to beginning	imeister	PowerPoint	1	02-02-2011 02:05 PM
loops within presentations	supateach	PowerPoint	1	11-23-2010 04:42 AM