For Loop Overwriting Data within Array - vba

Question

So I have a data set that is made up of a variety tag numbers - I'm trying to develop a VBA "fucntion" to basically give recommendation on a tag number when inputting a new one. This would be easy but the current list gives gaps within tag numbers (eg) goes 4001 4002 4005 . This bit of code is taking that gap and storing "option" tags which I plan to display to the user (so 4003 and 4004). The problem is that these gaps are encountered more than once eg) 4001 4002 4005 4006 4007 4011 4012 and when it comes to the second gap (4008 4009 4010) it overwrites the existing array - how can I get it take each gap and then begin the array below that?
My code is as follows:
For j = 2 To UBound(strArrayNumber)
If strArrayNumber(j) <> strArrayNumber(j - 1) + 1 Then
Gap = strArrayNumber(j) - strArrayNumber(j - 1)
For b = 1 To Gap
ReDim TagOptions(1 To Gap) As Integer
TagOptions(b) = strArrayNumber(j - 1) + b
sh.Cells(b, 6) = TagOptions(b)
Next b
End If

Answer 1

At the prompting of #JohnSUN here is the bare bones of a solution using Scripting.Dictionary.
The OP desires to manage a data set. To simplify this management I have chosen to create a TagList object. The TagList object allows
Population of the tag list from two arrays
Updating the value associated with a tag item
getting back an array of tags or object
getting an array of the next free tags
testing if a tag exists
This is a bare bones example as it is designed to point the way rather than provide a complete solution. It has some obvious ommisions, i.e. there is no code for what happens if a the request for the next set of free tags uses a tag that is higher then the maximum tag number, there is no error code for what happens if we try to add an existing tag to the TagList etc.
The Class Taglist code compiles without error and shows no significant inospection results after a Rubberduck code inspection
Class TagList
Option Explicit
Private Type State
' Requires a reference to 'Microsoft Scripting Runtime'
TagList As Scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
Set s.TagList = New Scripting.Dictionary
End Sub
Public Property Get Item(ByVal iptag As Long) As Variant
Item = s.TagList.Item(iptag)
End Property
Public Property Let Item(ByVal iptag As Long, ByVal ipitem As Variant)
s.TagList.Item(iptag) = ipitem
End Property
Public Function Tags() As Variant
Tags = s.TagList.keys
End Function
Public Function Items() As Variant
Items = s.TagList.Items
End Function
Public Sub Add(ByVal ipTags As Variant, Optional ByVal ipItems As Variant)
'ipTags and ipItems should be arrays of equal size
If IsMissing(ipItems) Then
ReDim ipItems(UBound(ipTags) - LBound(Tags) + 1)
End If
If (UBound(ipTags) - LBound(ipTags)) - (UBound(ipItems) - LBound(ipItems)) <> 0 Then
Err.Raise vbObjectError + 512, "Size Error", "Arrays are different sizes"
End If
Dim myItemsIndex As Long
myItemsIndex = LBound(ipItems)
Dim myTag As Variant
For Each myTag In ipTags
s.TagList.Add myTag, CVar(ipItems(myItemsIndex))
myItemsIndex = myItemsIndex + 1
Next
End Sub
Public Function Exists(ByVal iptag As Long) As Boolean
Exists = s.TagList.Exists(iptag)
End Function
Public Function NextFreeTags(ByVal iptag As Long) As Variant
If iptag < 1 Then
Err.Raise vbObjectError + 512, "Negative Tag", "Tag numbers must be positive"
End If
Dim myFreeTags As Scripting.Dictionary
Set myFreeTags = New Scripting.Dictionary
Do While s.TagList.Exists(iptag)
iptag = iptag + 1
Loop
Do Until s.TagList.Exists(iptag)
myFreeTags.Add iptag, iptag
iptag = iptag + 1
Loop
NextFreeTags = myFreeTags.keys
End Function
Thus we can now do the following
Dim myTagList as TagList
Set myTagList = New TagList
mytaglist.Add Array(4006, 4001, 4002, 4011, 4005, 4007)
' Note the above is the short form version we could equally say
' myTagList.add Array(4006, 4001, 4002, 4011, 4005, 4007), Array(Obj6, Obj1, Obj11, Obj5, Obj7)
'Oops, we forgot to add tag 4012
myTaglist.add array(4012)
' getting then next free tags
dim myTags as variant
myTags = myTaglist.NextFreeTags(4001)
etc

Answer 2

Let's not calculate the Gap. The parameters of the cycle by B can be any - we will use this. Try this:
Set oCell = sh.Range("F1")
TagOptions = Array()
For j = 2 To UBound(strArrayNumber)
If strArrayNumber(j) <> strArrayNumber(j - 1) + 1 Then
For b = strArrayNumber(j - 1) + 1 To strArrayNumber(j) - 1
uBoundTagOptions = UBound(TagOptions) + 1
ReDim Preserve TagOptions(1 To uBoundTagOptions)
TagOptions(uBoundTagOptions) = b
oCell.Value = b
Set oCell = oCell.Offset(1, 0)
Next b
End If
Next j
Don't forget to specify Option Base 1 at the beginning of the module, otherwise TagOptions = Array() will create an empty array [0..-1] , with LBound = 0, but you want from LBound = 1
UPDATE
By the way, there is one old trick using an auxiliary array. This is used to clear data from duplicates, for sorting and other things. The method is resource-intensive, but very fast. It looks something like this:
Function getGaps(aData As Variant) As Variant
Dim lB As Long, uB As Long, i As Long, lCount As Long
Dim aTemp() As Boolean, aResult() As Long
If IsArray(aData) Then
lB = Application.WorksheetFunction.Min(aData)
uB = Application.WorksheetFunction.Max(aData)
Rem Let's create an auxiliary array of boolean flags. It may be very large, but it won't be long.
ReDim aTemp(lB To uB)
Rem Let's mark in the array those values ??that are in the aData.
Rem In this case, we will skip duplicates, if any, and count the number of unique numbers.
lCount = 0
For i = LBound(aData) To UBound(aData)
If Not aTemp(aData(i)) Then
aTemp(aData(i)) = True
lCount = lCount + 1
End If
Next i
Rem Number of values in gaps:
uB = uB - lB - lCount + 1
If uB > 0 Then ' It may be that there were no gaps in the array
ReDim aResult(1 To uB)
lCount = 0
For i = LBound(aTemp) To UBound(aTemp)
If Not aTemp(i) Then
lCount = lCount + 1
aResult(lCount) = i
End If
Next i
Rem Here it is - the result of the function
getGaps = aResult
Rem The interpreter will destroy this variable immediately after exiting the function,
Rem but will free the memory a little later. This line should help free memory faster
ReDim aTemp(0)
End If
End If
Rem In all other cases, the function will return Empty
End Function
Despite the number of lines, it is very simple and very fast since all the work is done in RAM.
With this function, all the code you showed in your question becomes:
Set oCell = sh.Range("F1")
oCell.EntireColumn.ClearContents ' This is for the case where no gaps are found
TagOptions = getGaps(strArrayNumber)
If IsEmpty(TagOptions) Then
Debug.Print "No gaps in array"
Exit Sub
End If
oCell.Resize(UBound(TagOptions), 1).Value2 = Application.WorksheetFunction.Transpose(TagOptions)
Of course TRANSPOSE () might not work correctly for a very large array. But I hope that you are not so cruel to your users and the list of possible tags does not exceed a hundred or two.