I'm trying to code a program that has two sections depending on which of two buttons has been pressed.
The first section is the bit that is working, the user presses the first button labeled "unsort", this triggers a loop which displays an input box asking for a random number 8 times. These 8 numbers are stored in an array.
However it is the second section I'm struggling with; the second button is labeled sort and should output the numbers the user just entered using the first button is order, smallest to largest. I understand that a bubble sort must be used here and that a loop within a loop must also be used however it is the content of these loop that I don't understand. Since my original post I've edited the post to include some code in the loop I was previously stuck with, however it still isn't producing the desired output (all numbers in order) but is instead just outputting the numbers in a seemingly random order
The code is posted below with annotations:
Public Class BubbleSort1
Dim Bubble(8) As Integer
Dim UnsortedList As String
Dim n As Integer
Dim SortedList As String
Dim temp As String
Private Sub btnUnsort_Click(sender As Object, e As EventArgs) Handles btnUnsort.Click
n = 8 ' number off values on array
For i = 1 To n ' when i is between 1 and size of array
Bubble(i) = InputBox("Enter Number") ' User inputs a number
UnsortedList = UnsortedList & " " & Bubble(i) & vbNewLine ' number is added to the unsorted list variable
Next i
lblUnsort.Text = UnsortedList ' outputs the array
End Sub
Private Sub btnSort_Click(sender As Object, e As EventArgs) Handles btnSort.Click
For i = 1 To n - 1 ' When i is between 1 and the array size - 1 (8-1):
For j = 1 To n - 1 ' Second loop - when j is between 1 and the array size - 1 (8-1):
If Bubble(j) > Bubble(j + 1) Then ' if bubble value j is greater than value j - 1:
temp = Bubble(j)
Bubble(j) = Bubble(j + 1) ' These lines are supost to order the numbers but aren'r currently doing so
Bubble(j + 1) = temp
SortedList = SortedList & Bubble(j) & vbNewLine ' Adding the number in order to a variable
End If
Next j
Next i
lblSort.Text = SortedList ' outputting the ordered numbers
End Sub
End Class
As is pointed out in the code, the section of this code that orders the numbers is just putting them in a random order rather than actually ordering them.
With your updated code which now includes the swapping of array elements, you are building the string which shows the sorted array too soon: it will show the workings rather than the final result.
All you need to do is build the string once the array is in order:
Private Sub btnSort_Click(sender As Object, e As EventArgs) Handles btnSort.Click
' Bubble sort the array...
For i = 1 To n - 1 ' When i is between 1 and the array size - 1 (8-1):
For j = 1 To n - 1 ' Second loop - when j is between 1 and the array size - 1 (8-1):
If Bubble(j) > Bubble(j + 1) Then ' if bubble value j is greater than value j - 1:
temp = Bubble(j)
Bubble(j) = Bubble(j + 1)
Bubble(j + 1) = temp
End If
Next j
Next i
'lblSort.Text = String.Join(vbNewLine, Bubble.Skip(1)) ' an easy one-liner
' Create a string to show the sorted array...
SortedList = "" ' clear it out in case it was used previously
For i = 1 To n
SortedList = SortedList & Bubble(i).ToString()
If i < n Then ' only add a newline if it isn't the last element
SortedList = SortedList & vbNewLine
End If
Next
lblSort.Text = SortedList
End Sub
I put the .ToString() in there in anticipation of you explicitly converting the input strings into numbers; strictly speaking, the & operator will convert its arguments into strings but I prefer to make it obvious in the code.
As your code is, there is an implicit conversion from the input (a string of digits) into an integer (the type of the array elements). While this seems convenient, it can be a problem if VB guesses the wrong conversion for you. There is a way to tell it to let you know if the types of variables don't match: put Option Strict On as the very first line and it will even give you suggestions on what needs to be done to put it right.
If you want to prompt the user for the input, then you will first need to either get a numeric value using a control like a NumericUpDown or you will need to convert the String value to an Integer value using Integer.TryParse. Also, keep in mind that arrays in VB.Net have a 0 based index, so they start at 0, not at 1.
In terms of the Bubble Sort algorithm, you'll need a nested loop like you have with i and j, only your inner-nested loop (j) needs to iterate from the beginning of the array to the second to last item (0 to n-2). Inside of the nested loops, you would compare if the currently iterated value is greater than (or less than depending on which value you want to swap) than the next value. If so, then you'd just reassign the values at the currently iterated index.
Here is a console application example that I whipped up, it does not prompt the user for random values, rather it simply gets a collection of random values and then performs the Bubble Sort:
Private Function BubbleSort(ByVal values() As Integer) As Integer()
'Declare placeholder variables to use in the iterations
Dim temp As Integer
For outterIndex As Integer = 0 To values.Length - 1
For innerIndex As Integer = 0 To values.Length - 2
If values(innerIndex) > values(innerIndex + 1) Then
temp = values(innerIndex + 1)
values(innerIndex + 1) = values(innerIndex)
values(innerIndex) = temp
End If
Next
Next
Return values
End Function
Private r As New Random()
Private Function RandomNumbers(ByVal range As Integer) As Integer()
'Throw an exception if the value is less than 1
If range < 1 Then Throw New ArgumentOutOfRangeException("The range cannot be less than 1")
'Return a collection of random numbers
Return Enumerable.Range(1, range).Select(Function(i) r.Next()).ToArray()
End Function
Fiddle: Live Demo
Related
I have a 2d array and would like to sort each row based on the final column. I have created a mergesort algorithm in VBScript (which is what I am going to use) that does the sorting for a single column. But I would like to sort every row based on the final column like this, where I want the rows to be sorted based on the last row.
Name | X value | Y value | Z value
R1 | 10 | 3 | 2
There is a code mentioned in this post that does sorting for single dimension array sorting (https://stackoverflow.com/a/10351062/17862830). I have tried editing this code to solve my problem by extracting the integer that I am comparing from the strings in the array (extracting 19 from "Name,0,0,0,0,19"). However, I am not sure why does the code not work well as compared to doing it as just pure integer.
'The merge function.
Public Function Merge(LeftArray, RightArray, Order)
'Declared variables
Dim FinalArray
Dim FinalArraySize
Dim i
Dim LArrayPosition
Dim RArrayPosition
'Variable initialization
LArrayPosition = 0
RArrayPosition = 0
'Calculate the expected size of the array based on the two smaller arrays.
FinalArraySize = UBound(LeftArray) + UBound(RightArray) + 1
ReDim FinalArray(FinalArraySize)
'This should go until we need to exit the function.
While True
'If we are done with all the values in the left array. Add the rest of the right array
'to the final array.
If LArrayPosition >= UBound(LeftArray)+1 Then
For i=RArrayPosition To UBound(RightArray)
FinalArray(LArrayPosition+i) = RightArray(i)
Next
Merge = FinalArray
Exit Function
'If we are done with all the values in the right array. Add the rest of the left array
'to the final array.
ElseIf RArrayPosition >= UBound(RightArray)+1 Then
For i=LArrayPosition To UBound(LeftArray)
FinalArray(i+RArrayPosition) = LeftArray(i)
Next
Merge = FinalArray
Exit Function
'For descending, if the current value of the left array is greater than the right array
'then add it to the final array. The position of the left array will then be incremented
'by one.
ElseIf getNumber(LeftArray(LArrayPosition)) > getNumber(RightArray(RArrayPosition)) And UCase(Order) = "DESC" Then'**
FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
LArrayPosition = LArrayPosition + 1
'For ascending, if the current value of the left array is less than the right array
'then add it to the final array. The position of the left array will then be incremented
'by one.
ElseIf getNumber(LeftArray(LArrayPosition)) < getNumber(RightArray(RArrayPosition)) And UCase(Order) = "ASC" Then'**
FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
LArrayPosition = LArrayPosition + 1
'For anything else that wasn't covered, add the current value of the right array to the
'final array.
Else
FinalArray(LArrayPosition+RArrayPosition) = RightArray(RArrayPosition)
RArrayPosition = RArrayPosition + 1
End If
Wend
End Function
'The main sort function.
Public Function Sort(ArrayToSort, Order)
'Variable declaration.
Dim i
Dim LeftArray
Dim Modifier
Dim RightArray
'Check to make sure the order parameter is okay.
If Not UCase(Order)="ASC" And Not UCase(Order)="DESC" Then
Exit Function
End If
'If the array is a singleton or 0 then it is sorted.
If UBound(ArrayToSort) <= 0 Then
Sort = ArrayToSort
Exit Function
End If
'Setting up the modifier to help us split the array effectively since the round
'functions aren't helpful in VBScript.
If UBound(ArrayToSort) Mod 2 = 0 Then
Modifier = 1
Else
Modifier = 0
End If
'Setup the arrays to about half the size of the main array.
ReDim LeftArray(Fix(UBound(ArrayToSort)/2))
ReDim RightArray(Fix(UBound(ArrayToSort)/2)-Modifier)
'Add the first half of the values to one array.
For i=0 To UBound(LeftArray)
LeftArray(i) = ArrayToSort(i)
Next
'Add the other half of the values to the other array.
For i=0 To UBound(RightArray)
RightArray(i) = ArrayToSort(i+Fix(UBound(ArrayToSort)/2)+1)
Next
'Merge the sorted arrays.
Sort = Merge(Sort(LeftArray, Order), Sort(RightArray, Order), Order)
End Function
Dim arr
arr = Array("R1,0,0,0,0,12","R1,0,0,0,0,1","R1,0,0,0,0,2","R1,0,0,0,0,124", "R1,0,0,0,0,150","R1,0,0,0,0,9756","R1,0,0,0,0,200","R1,0,0,0,0,14","R1,0,0,0,0,-124","R1,0,0,0,0,-12","R1,0,0,0,0,0")
Dim sortarr : sortarr = Sort(arr, "asc")
Dim secsortarr : secsortarr = Sort(sortarr, "asc")
For i=0 To UBound(secsortarr)
MsgBox(secsortarr(i))
Next
Function getNumber(row)
Dim holdarr
holdarr = Split(row, ",")
getnumber = holdarr(UBound(holdarr))
End Function
I have been using some useful VBA code by PEH that uses regular expression to extract the number of instances of a specific element in a chemical formula, see: https://stackoverflow.com/a/46091904/17194644
It works well, but everything slows down when I use the function hundreds of times in one worksheet. I was wondering if this might be due to the time it takes VBA to read/write values from/to the cells, so I created an array function (based on the regex code by PEH) to see if it would speed things up, see below. The function works and is quicker but can still slow things down when dealing with hundreds of values, and I cannot get the second part to work that finds multiplies elements within parenthesis. Any thoughts on how to improve further?
Function CountElements(ChemFormulaRange As Variant, ElementRange As Variant) As Variant
'define variables
Dim RetValRange() As Long
Dim RetVal As Long
Dim ChemFormula As String
Dim npoints As Long
Dim i As Long
Dim mpoints As Long
Dim j As Long
' Convert input ranges to variant arrays
If TypeName(ChemFormulaRange) = "Range" Then ChemFormulaRange = ChemFormulaRange.Value
If TypeName(ElementRange) = "Range" Then ElementRange = ElementRange.Value
'parameter
npoints = UBound(ChemFormulaRange, 1) - LBound(ChemFormulaRange, 1) + 1
mpoints = UBound(ElementRange, 2) - LBound(ElementRange, 2) + 1
'dimension arrays
ReDim RetValRange(1 To npoints, 1 To mpoints)
'calculate all values
For j = 1 To mpoints
Element = ElementRange(1, j)
For i = 1 To npoints
RetVal = 0
ChemFormula = ChemFormulaRange(i, 1)
Call ChemRegex(ChemFormula, Element, RetVal)
RetValRange(i, j) = RetVal
Next i
Next j
'output answer
CountElements = RetValRange
End Function
Private Sub ChemRegex(ChemFormula, Element, RetVal)
Dim regEx As New RegExp
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
'first pattern matches every element once
regEx.Pattern = "([A][cglmrstu]|[B][aehikr]?|[C][adeflmnorsu]?|[D][bsy]|[E][rsu]|[F][elmr]?|[G][ade]|[H][efgos]?|[I][nr]?|[K][r]?|[L][airuv]|[M][cdgnot]|[N][abdehiop]?|[O][gs]?|[P][abdmortu]?|[R][abefghnu]|[S][bcegimnr]?|[T][abcehilms]|[U]|[V]|[W]|[X][e]|[Y][b]?|[Z][nr])([0-9]*)"
Dim Matches As MatchCollection
Set Matches = regEx.Execute(ChemFormula)
Dim m As Match
For Each m In Matches
If m.SubMatches(0) = Element Then
RetVal = RetVal + IIf(Not m.SubMatches(1) = vbNullString, m.SubMatches(1), 1)
End If
Next m
'second patternd finds parenthesis and multiplies elements within
' regEx.Pattern = "(\((.+?)\)([0-9])+)+?"
' Set Matches = regEx.Execute(ChemFormula)
' For Each m In Matches
' RetVal = RetVal + ChemFormula(m.SubMatches(1), Element) * (m.SubMatches(2) - 1) '-1 because all elements were already counted once in the first pattern
' Next m
End Sub
If you are using Office 365, then you do not need VBA. A formula can achieve what you want and I think it would be faster.
=TRIM(TEXTJOIN("",TRUE,IFERROR((MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)*1)," ")))
Note: If you still need a VBA solution then remember you can enter the above formula in the entire range in one go and then convert it to values.
rng.Formula = "=TRIM(TEXTJOIN("""",TRUE,IFERROR((MID(A1,ROW(INDIRECT(""1:""&LEN(A1))),1)*1),"" "")))"
rng.Value = rng.Value
The slowest part of your ChemRegex routine is creating the RegExp object.
If all your cells are passed to CountElements as a pair of large areas move the code that creates the RegExp object and applies a few properties from ChemRegex to CountElements, and pass the RegExp reference from CountElements to ChemRegex.
Or, if you are calling CountElements as say a UDF in multiple cells, declare RegExp at module level
Private RegEx as RegExp
In CountElements...
If RegEx is Nothing Then
Set RegEx = New RegExp
' apply the properties
End If
' code
' and pass RegEx to ChemRegex
Call ChemRegex(ChemFormula, Element, RetVal, RegEx)
Isolate all numbers in chemical formula
Just for the sake of the art an alternative to Siddharth 's approach, where I demonstrate how to use Match() comparing
an array of each formula character|digit in the given string with
an array of all regular digits.
This allows to identify array elements (here: digits) based on their position. So this demo might be also helpful to solve similar requirements. - I don't pretend this to be a better or faster way.
Function ChemNo(ByVal s As String) As Variant
'Purp: return array of found character positions in chars string
'Note: (non-findings show Error 2042; can be identified by IsError + Not IsNumeric)
Dim digits
digits = String2Arr("1234567890")
'get any digit position within array digits ' note: zero position returns 10
Dim tmp
tmp = Application.Match(String2Arr(s), digits, 0)
'check for digits in a loop through tmp
Dim i As Long, ii As Long
For i = 1 To UBound(tmp)
If IsNumeric(tmp(i)) Then ' found digit
tmp(i) = tmp(i) Mod 10 ' get digtis including zeros
If IsNumeric(tmp(i - 1)) Then ' check preceding digit
tmp(i) = 10 * tmp(i - 1) + tmp(i) ' complete number
tmp(i - 1) = "!" ' mark former digit
End If
Else
tmp(i) = "!" ' mark non-numeric element
End If
Next i
ChemNo = Filter(tmp, "!", False) ' delete marked elements
End Function
Help function String2Arr()
Assigns an array of single characters after atomizing a string input:
Function String2Arr(ByVal s As String) As Variant
'Purp: return array of all single characters in a string
'Idea: https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
s = StrConv(s, vbUnicode)
String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
If you want to use the function as tabular input profiting from the newer dynamic features in Excel, you may enter it as user defined function e.g. in cell B1: =ChemNo(A1) displaying each number horizontally in as so called spill range. Using older versions, I suppose you'd need a CSE entry (Ctrl↑┘) to mark it as {array} formula.
I have two string arrays with quite a few items. The items are unique in each array: I sort the array alphabetically and remove duplicates as I do so.
I want to know how many of the items in array a are also present in array b. As soon as there is even one of such items that occurs in both arrays, I "know enough".
And even though both arrays are sorted alphabetically first, doing a double loop as below is very heavy on the processor and terribly slow.
So I'm looking for an alternative, or even an other approach from the start...
Dim aryA(1 To 10000) As String
Dim aryB(1 To 10000) As String
Dim x As Long
Dim y As Long
Dim Counter as long
Counter = 0
'fill arrays with many values
For x = 1 to 10000
For y = 1 to 10000
If aryA(x) = aryB(y) Then
counter = counter + 1
Exit For
End If
Next y
Next x
If Flag = True Then
'run amazing code here
End If
End Sub```
Thanks!
You should try using Dictionaries instead of arrays.
I did a test with 1'000, 10'000 and 100'000 words and compared all elements (so not breaking when a duplicate was found) on a very regular computer. Using 1'000 elements was ready instantly, 10'000 took not much more that the blink of the eye, 100'000 2-3 seconds.
I don't know how your original data is from or how you will your arrays. The following code just copies the arrays into dictionaries and then loop over the keys of the first dictionary and looks if it is present in the second. No need to have the data sorted, and duplicates are eliminated automatically when the dictionary is build.
If your not familiar with Dictionaries: You need to add a reference to the "Microsoft Scripting Runtime" (or change code to late binding).
Sub arrayTest()
' (omitting my test code to fill up the arrays)
' Create Dictionaries
Dim d1 As New Dictionary
Dim d2 As New Dictionary
For x = 1 To UBound(aryA)
If Not d1.Exists(aryA(x)) Then d1.Add aryA(x), vbNullString
Next x
For y = 1 To UBound(aryB)
If Not d2.Exists(aryB(y)) Then d2.Add aryB(y), vbNullString
Next
' Compare the dictionaries
Counter = 0
Dim k
For Each k In d1.Keys
If d2.Exists(k) Then Counter = Counter + 1
Next
Debug.Print "Done: " & Counter
End Sub
If you just need this check once and don't do anything with the data afterwards, of course it is not necessary to create the second dictionary:
For x = 1 To UBound(aryA)
If Not d1.Exists(aryA(x)) Then d1.Add aryA(x), vbNullString
Next x
For y = 1 To UBound(aryB)
If d1.Exists(aryB(y)) Then Counter = Counter + 1
Next
Debug.Print "Done: " & Counter
If both array are sorted you could just go through them considering their ordering in linear time:
Pseudo code:
i=0;
j=0;
while i < len(aryA) and j < len(aryB) do
if aryA[i] == aryB[j] then
counter++;
i++;
j++;
elseif aryA[i] > aryB[j] then
j++
else
i++;
fi
done
I have a column of data with unique strings where the first 4 characters in the string may be a repeat of the first 4 characters in another string, in a format similar to:
ABCDEF
ABCDXY
ABCDKL
DTYTZF
DTYTSD
I am attempting to loop through this data to identify which 4 starting characters appear more then three times. If the first 4 digits of the string occur 3 times or more, I would like to remove these from the array entirely, and end up with an array that excludes these values. For example, in my column above, as 3 strings or more begin with 'ABCD', I would like to remove all strings that begin with this code, and have only every other value remain, such that my result would be:
DTYTZF
DTYTSD
I am currently looping through the array, pushing any value that occurs three times or more into a NEW array, and plan to then use that list to do a second pass on the original array, and remove any matches. This may not be the most efficient way, but I've not been able to determine a better way that is guaranteed not to mess my data up.
I have worked through looping through the strings to identify which strings occur more then once, but when I try to push them to an array, the string successfully is pushed to the array, but is then replaced with the next value as soon as it is pushed to the array. I know the value is pushed correctly, because if I view the array immediately afterwards, I see the value in the array. When the next value is pushed and you view the array again, only the new value is displayed (The older ones are not).
I believe this is due to my limited understanding of ReDim-ing arrays, and me not fully understanding a code snippet for pushing this value into an array. My (condensed) code is as follows:
Sub pickupValues()
Dim valuesArray()
Dim i As Long
Dim y As Long
Dim sizeCheck As Long
Dim tempArray() As String
valuesArray() = Worksheets("Sheet1").Range("A1:A10").Value
For i = LBound(valuesArray) To UBound(valuesArray)
sizeCheck = 0
For y = LBound(valuesArray) To UBound(valuesArray)
If Left(valuesArray(i, 1), 4) = Left(valuesArray(y, 1), 4) Then
sizeCheck = sizeCheck + 1
i = y
If sizeCheck >= 3 Then
ReDim tempArray(1 To 1) As String 'I'm not sure why I need to do this.
tempArray(UBound(tempArray)) = Left(valuesArray(i, 1), 4) 'I believe this is what pushes the value into the array.
ReDim Preserve tempArray(1 To UBound(tempArray) + 1) As String 'Again unsure on what the purpose of this is.
viewArray (tempArray)
End If
End If
Next y
Next i
End Sub
Function viewArray(myArray)
Dim txt As String
Dim i As Long
For i = LBound(myArray) To UBound(myArray)
txt = txt + myArray(i) + vbCrLf
Next i
MsgBox txt
End Function
What am I doing wrong?
I would like to re-use the same basic code later in the function to push other values OUT of an array based on if they match the string or not, but it seems VBA does not like to move values out of arrays either. Is there an easy solution that would match both scenarios?
I've rewritten what you are trying to do. I'm using the filter function to quickly get your results in the array
Option Explicit
Public Sub pickupValues()
Dim tmp As Variant
Dim results As Variant
Dim i As Long
Dim v
' Make sure this matches your range
With ThisWorkbook.Sheets("Sheet1")
' Important to transpose the input here as Filter will only take a 1D array. Even though it's only 1 column, setting an array this way will generate a 2D array
tmp = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value2)
End With
' ReDiming to the maximum value and slimming down afterwards is much quicker then increasing your array each time you've found a new value
ReDim results(1 To UBound(tmp))
For Each v In tmp
' Less then 2 as first result is '0'. Will return '-1' if can't be found but as test criteria is in the array it will always be at least 0
If UBound(Filter(tmp, Left(v, 4))) < 2 Then
i = i + 1
results(i) = v
End If
Next v
' Redim Preserve down to actual array size
If i > 0 Then
ReDim Preserve results(1 To i)
viewArray (results)
Else
MsgBox "Nothing Found"
End If
End Sub
' Should really be a sub as doesn't return anything back to caller
Public Sub viewArray(myArray)
MsgBox Join(myArray, vbCrLf)
End Sub
Your algorithm is not helping you.
Option 1:
Sort your array. Then you can make a single pass to find sequential values with the same first four characters and count them.
Option 2:
Use a Dictionary object: first four characters as key, number of occurrences as value.
I have a Variant in VB6 with thousands of Strings.
I also have an array of fixed length.
I need to compare the contents of each and add the ones that match to a list.
if array(i) = variant(1,i) then
'add to list
End if
I cannot figure out how to iterate over both properly in order to compare, as the method I use to iterate over the Variant() stops after going through each item. So it never checks to see if it any item is equal to i+1 in the array.
Private Sub dp_Click()
Dim fArray
fArray = Array("a", "b", "c")
LstAPens.ListItems.Clear
LstUPens.ListItems.Clear
For x = 0 To UBound(fArray)
Dim i As Long, m As Integer
'Do Until batcharray(0, i) = "End"
' tmpArray(i) = UCase(batcharray(1, i))
'Loop
Do Until batcharray(0, i) = "End"
If (InStr(1, UCase(batcharray(1, i)), UCase(fArray(x))) > 0) Then
LstAPens.ListItems.Add
With LstAPens.ListItems(m + 1)
.SubItems(1) = batcharray(1, i) 'Tagname
End With
m = m + 1
End If
i=i+1
Loop
Next x
End Sub
I tried to convert the Variant to an array but it did not work.
The only item that is found is the first one in the array, then the Variant is no longer iterated over as it reached the end.
How can I iterate over the Variant called batchArray in this example, and compare it to the contents of an array?
This really isn't a Variant problem, it's just a looping/control variable issue.
Even though you have your DIM statement inside your main loop, VB does not treat that as a "redeclaration" and reset/reinitialize its value before your UNTIL loop. As a result, 'i' will increment to 1 and then retain its value between iterations of your outer loop, thus remaining stuck on the single value in batchArray and the iteration ceases.
Move the declaration outside the loop, reset it to 0 before the UNTIL loop, and see if that solves your problem:
Dim i as Long
For x = 0 To UBound(fArray)
Dim m As Integer
i = 0
Do Until batcharray(0, i) = "End"
If (InStr(1, UCase(batcharray(1, i)), UCase(fArray(x))) > 0) Then
LstAPens.ListItems.Add
With LstAPens.ListItems(m + 1)
.SubItems(1) = batcharray(1, i) 'Tagname
End With
m = m + 1
End If
i=i+1
Loop
Next x