I have an array an VBA
strname=[English,science,Social,English,Social,science,science,Social,English,,,]
I want to remove duplicates and empty values in this array and concatenate them.
Expected Output : English;science;Social
I tried with looping logic but it doesnt work
For i=0 to 10
if strname[i] <> "" then
if strname[i]= strname[i+1] then
tempstr=strname[i]
end i
end if
next
here it will check 0 with 1 , 1 with 2 like that.Am trying for proper solution
Please, try the next way:
Sub removeArrDuplAndEmpty()
Dim x As String, arr, i As Long, dict As Object
x = "English,science,Social,English,Social,science,science,Social,English,,,"
Set dict = CreateObject("Scripting.Dictionary")
arr = Split(x, ",") 'extract the array
For i = 0 To UBound(arr)
If arr(i) <> "" Then dict(arr(i)) = 1 'create unique keys for non blank array elements
Next
arr = dict.keys 'place back the dictionary keys in the initial array
Debug.Print Join(arr, ";") 'only to visually see the result
End Sub
The next version processes the string as you show it in your question:
Sub removeArrDuplAndEmptyBis()
Dim x As String, arr, i As Long, dict As Object
x = "[English,science,Social,English,Social,science,science,Social,English,,,]"
Set dict = CreateObject("Scripting.Dictionary")
arr = Split(left(Mid(x, 2), Len(Mid(x, 2)) - 1), ",")
For i = 0 To UBound(arr)
If arr(i) <> "" Then dict(arr(i)) = 1
Next i
arr = dict.keys
Debug.Print Join(arr, ",")
End Sub
This is what you want?
If not, please show an example of your real string and how it must look after processing...
Related
I need to do a is nothing check on a Variant array to exclude empty indexes from being used. I use is nothing to capture empty indexes which hold (empty) objects, it works fine but for indexes that hold regular data types (not objects), it throws an exception.
Dim arrArray() as Variant
'... fill array with values but leave some indexes out
'Loop through the array
For i = LBound(arrArray) To UBound(arrArray)
'Check if the current array item is an empty object
If arrArray(i) Is Nothing Then
'don't debug.print
'Debug if it's not an empty object
Else
Debug.Print arrArray(i)
End If
Next
I could use on error resume next but since error handling is done dynamically it would change the error handling status so I would like to avoid that. If it can't be avoided please check my other question.
Note: Currently I just work with empty objects, at some point in the future I might get an actual object. So in the long run I will have to check if the index contains an existing object (otherwise - I presume - debug.print will throw an error).
Please, try the next function. It will return a cleaned array (without empty elements) for a wide range of elements type:
Function elimEmptyArrayElements(arrX As Variant) As Variant
Dim i As Long, arrNoEmpty, k As Long
ReDim arrNoEmpty(UBound(arrX)): k = 0
For i = LBound(arrX) To UBound(arrX)
If Not IsMissing(arrX(i)) Then
If Not IsObject(arrX(i)) Then
If TypeName(arrX(i)) = "String" Then
If arrX(i) <> "" Then
arrNoEmpty(k) = arrX(i): k = k + 1
End If
Else
If Not IsEmpty(arrX(i)) Then
arrNoEmpty(k) = arrX(i): k = k + 1
End If
End If
Else
Set arrNoEmpty(k) = arrX(i): k = k + 1
End If
End If
Next i
ReDim Preserve arrNoEmpty(k - 1)
elimEmptyArrayElements = arrNoEmpty
End Function
Please, test it using the next Sub. It will stop on each pair of initial/cleaned array representation. When possible, both arrays are joined in Immediate Window.
If not possible, only the number of their elements (Ubound(arr)) is returned. You may iterate between each array elements and see that no empty one exists:
Sub testElimEmptyArrayElements()
Dim arr
arr = Split("1,7,9,,10,5,6,,2,8,3,4", ",")
Debug.Print Join(arr, "|") 'just to visually see the initial array content
arr = elimEmptyArrayElements(arr)
Debug.Print Join(arr, "|"): Stop 'the cleaned array
arr = Application.Transpose(Range("A2:A20").value) 'a 1D array extracted from a column range
Debug.Print Join(arr, "|")
arr = elimEmptyArrayElements(arr)
Debug.Print Join(arr, "|"): Stop 'the cleaned array
arr = Array(1, 2, 3, , 4, , 5): Debug.Print "Initial number of numeric elements: " & UBound(arr)
arr = elimEmptyArrayElements(arr): Debug.Print "Cleaned array number of numeric elements: " & UBound(arr): Stop
arr = Array(Range("A2"), Range("A3"), , Range("A6")): Debug.Print "Initial number of Range Object elements: " & UBound(arr)
arr = elimEmptyArrayElements(arr): Debug.Print "Cleaned array number of Range elements: " & UBound(arr): Stop
arr = Array(ActiveSheet, , ActiveSheet.Next): Debug.Print "Initial number of Sheet Object elements: " & UBound(arr)
arr = elimEmptyArrayElements(arr): Debug.Print "Cleaned array number of Sheet Object elements: " & UBound(arr): Stop
arr = Array("my string", 100, Range("A2"), , ActiveSheet, , ThisWorkbook, "test", 6): Debug.Print "Initial number of variate elements: " & UBound(arr)
arr = elimEmptyArrayElements(arr): Debug.Print "Cleaned array number of variate types elements: " & UBound(arr)
Debug.Print arr(2).value 'the cell value
Debug.Print arr(3).name 'the activesheet name
Debug.Print arr(4).Sheets.count 'activeworkbook number of sheets
End Sub
You can simply check and filter your array for empty slots with if YourArray(i)<>"" then syntax
Beside that, I see some wrong declaration issues in first line of your code:
1-You can't use Array as a name for your array
2-You should use parentheses after you array name (e.g. Dim myArray() as variant)
3-Variable type can not have parentheses (As far as I know)
I recommend to declare your array like following:
dim arr()
This way it automatically considered as an array of variants. So my suggested code would be like this:
Dim arr()
'... fill array with values but leave some indexes out
For i = LBound(arr) To UBound(arr)
If arr(i)<>"" Then
'do nothing
Else
'do something
end if
Next i
I have an array like this
dim arr(1 to 5) as string
arr(1)="a"
arr(3)="b"
arr(5) = "c"
(arr(2),arr(4) are empty).
How can I redim this arr(1to5) to exclude empty values and save also values "a","b","c" (I want the output like arr(1to3), arr(1)="a", arr(2)="b", arr(3)="c")?
In general I do not know how many of them will be empty, so I need some general code for this (not for this specific example).
I was thinking about new temporary array to save all nonempty values and then redim arr(1to5).
Maybe it is a better (quick) way to do it?
I wrote sth similar:
Sub test()
Dim myArray() As String
Dim i As Long
Dim y As Long
ReDim Preserve myArray(3)
myArray(1) = "a"
myArray(3) = "c"
Dim myArray2() As String
y = 1
For i = LBound(myArray) To UBound(myArray)
If myArray(i) <> "" Then
ReDim Preserve myArray2(y)
myArray2(y) = myArray(i)
y = y + 1
End If
Next i
ReDim myArray(UBound(myArray2))
myArray = myArray2
End Sub
However I would like to avoid creating new array.
create a new array of the same size. Loop the first array and insert the values when not empty into the new array keeping track of the last spot with value in the new array, then redim preserve the new array to only the size that has values.
Sub kjlkj()
Dim arr(1 To 5) As String
arr(1) = "a"
arr(3) = "b"
arr(5) = "c"
Dim newArr() As String
ReDim newArr(1 To UBound(arr))
Dim j As Long
j = LBound(newArr)
Dim i As Long
For i = LBound(arr) To UBound(arr)
If arr(i) <> "" Then
newArr(j) = arr(i)
j = j + 1
End If
Next i
ReDim Preserve newArr(LBound(newArr) To j - 1)
'do what you want with the new array.
End Sub
Alternative via Filter() function
"However I would like to avoid creating new array."
A negative filtering allows a basically simple alternative, however you have to
declare your array dynamically (i.e. without preset number of elements) to allow a rebuild overwriting the original array,
execute a double replacement over the joined array elements to allow insertion of a unique character that can be filtered out.
Sub testFilter()
Dim arr() As String
ReDim arr(1 To 5)
arr(1) = "a"
arr(3) = "b"
arr(5) = "c"
'Debug.Print Join(arr, ",") ' ~~> a,,b,,c
'rearrange arr via RemoveEmpty()
arr = RemoveEmpty(arr) ' >> function RemoveEmpty()
Debug.Print Join(arr, ",") ' ~~> a,b,c
End Sub
Help function RemoveEmpty()
Adding an unused unique character, e.g. $, to the empty elements plus eventual negative filtering allows to remove these marked elements.
Note that the double replacement is necessary to allow to mark consecutive empty elements by the $ mark, as VBA would skip additional characters here.
Function RemoveEmpty(arr)
Dim tmp
tmp = Replace(Replace(Join(arr, "|"), "||", "|$|"), "||", "|$|")
RemoveEmpty = Filter(Split(tmp, "|"), "$", False)
End Function
In Excel, I have an array from A1 to P30 filled with names. Some cells have the same name (duplicate).
Is there a formula possible to list all the content of this array in one single column (on another sheet)? This list must gather only unique name (no duplicate).
Thanks in advance.
Try this:
Function Unique(strRng As String) As Variant()
Dim Arr() As Variant
ReDim Arr(0)
Dim rng As Range
Dim c As Range
Dim Duplicated As Boolean
Dim i As Long
Dim j As Long
j = 0
Set rng = Range(strRng)
For Each c In rng.Cells
Duplicated = False
If c.Value <> vbNullString Then
For i = LBound(Arr) To UBound(Arr)
If c.Value = Arr(i) Then
Duplicated = True
Exit For
End If
Next i
If Not Duplicated Then
ReDim Preserve Arr(j)
Arr(j) = c.Value
j = j + 1
End If
End If
Next c
Unique = Arr
End Function 'Unique
Update
Seems you insist to using a function. Easy. Create a User Defined Function (UDF) as below:
Function Unique(rng As Range) As Variant()
Dim Arr() As Variant
ReDim Arr(0)
Dim c As Range
Dim Duplicated As Boolean
Dim i As Long
Dim j As Long
j = 0
For Each c In rng.Cells
Duplicated = False
If c.Value <> vbNullString Then
For i = LBound(Arr) To UBound(Arr)
If c.Value = Arr(i) Then
Duplicated = True
Exit For
End If
Next i
If Not Duplicated Then
ReDim Preserve Arr(j)
Arr(j) = c.Value
j = j + 1
End If
End If
Next c
Unique = Arr
' OR
'Unique = Application.Transpose(Arr) 'Use this when you want transpose your range from row to column or back.
End Function 'Unique
How to use the function?
Note that this is an array form function.
Write second code in VBA.
select the range you want to return your unique values. (In each sheet and each part of column)
Write =Unique(A1:P30) in formula bar and then press Ctrl + Shift + Enter from keyboard. (Dont press Enter only)
Now, you have a formula that return you unique values of a range as you said.
I prefer to use a Collection or Dictionary to check for duplicates.
In this example I use an ArrayList
Sub ProcessNames()
Dim v As Variant
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With Worksheets("Sheet1")
For Each v In .Range("A1:P30").Value
If Not list.Contains(v) Then list.Add v
End With
'1 Dimensional 0 Based Array which will span 1 Row
v = list.ToArray
'2 Dimensional 1 Based Array that will span 1 Column
v = WorksheetFunction.Transpose(v)
End Sub
I have the below code that adds values to an array if it meets a criteria.
It keeps looping horizontally through the columns across a row and then repeats the same for the next row and so on.
I am trying to clear the values accumulated in the array and empty it at the end of the columns loop:
For a = 21 To 23
Count = 0
For b = 2 To 36
If Not Worksheets("Sheet1").Cells(a, b).Value = "A" And Not Worksheets("Sheet1").Cells(a, b).Value = "B" Then
Count = Count + 1
Else
If Not Count = 0 Then
Dim arr() As Long
arrLen = 1
ReDim Preserve arr(1 To arrLen)
arr(arrLen) = Count
arrLen = arrLen + 1
For i = LBound(arr) To UBound(arr)
msg = msg & arr(i) & vbNewLine
Next i
Count = 0
End If
End If
Next b
MsgBox Worksheets("Sheet1").Cells(a, 1).Value & vbNewLine & msg
Erase arr 'not working
Next a
As you can see from the above code, I get a msgbox displaying the values at the end of each loop, however as it continues, the array keeps getting bigger and bigger indicating that the Erase line is not working.
Kindly help!
You can either use a loop to set the array elements to nulls, or ReDim the array away:
Sub marine()
Dim arr()
ReDim arr(1 To 2)
arr(1) = "Alpha"
arr(2) = "Beta"
ReDim arr(1 To 1)
arr(1) = ""
End Sub
That way you can re-use the same array name later in the sub.
I'm looking for a little guidance and experience. I have an VBA module that creates two strings. See below. I want to use an array to compare the two stings and write the successful matches or "no match" for the element to a third array or directly to the worksheet.
The second part of this is a "percent of" match of Arr2 to Arr1. So the below example would be 88%.
> Arr1 result
> 726741,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X
> Arr2 result
> 726742,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X
Any advice would be great.
Here is one way to accomplish the task using simple for loops.
Sub compareStrings()
Dim str1 As String
Dim str2 As String
str1 = "726741,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
str2 = "726742,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
Dim Arr1 As Variant
Dim Arr2 As Variant
Dim ArrResults As Variant
Arr1 = Split(str1, ",")
Arr2 = Split(str2, ",")
Dim countMatches As Integer
countMatches = 0
ReDim ArrResults(UBound(Arr1))
For i = LBound(Arr1) To UBound(Arr1)
If Arr1(i) = Arr2(i) Then
ArrResults(i) = "Matches"
countMatches = countMatches + 1
Else
ArrResults(i) = "No Match"
End If
Next i
'Print out the results array in debug window
For Each entry In ArrResults
Debug.Print entry
Next entry
Dim ratio As Double
ratio = countMatches / (UBound(Arr1) + 1)
MsgBox (ratio * 100 & "%")
End Sub
Message box will display this:
Immediate window will display the results array values like this:
Try this:
Sub Test()
Dim str1 As String, str2 As String
Dim arr, i As Long, cnt As Long
str1 = "726741,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
str2 = "726742,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
For i = LBound(Split(str1, ",")) To UBound(Split(str1, ","))
If Not IsArray(arr) Then
arr = Array(IIf(Split(str1, ",")(i) = _
Split(str2, ",")(i), "Match", "NoMatch"))
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = IIf(Split(str1, ",")(i) = _
Split(str2, ",")(i), "Match", "NoMatch")
End If
Next
'~~> Check the array
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
If arr(i) = "Match" Then cnt = cnt + 1
Next
'~~> output the percentage
MsgBox Format(cnt / (UBound(arr) + 1), "0.00%")
End Sub