#1
|
|||
|
|||
Searching Arrays without Loops?
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 |
#2
|
|||
|
|||
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 |
#3
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
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!! |
Thread Tools | |
Display Modes | |
|
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 |