I have a problem with adding these 2 arrays together.
I have arr1 and arr2 this string elements.
arr1(0) = "000"
arr1(1) = "001"
arr1(2) = "002"
arr1(3) = "003"
arr1(4) = "004"
arr1(5) = "005"
arr2(0) = "Closed"
arr2(1) = "Open"
These arrays can be in dynamic size and values. (just added static values for demonstration)
I want to copy these items values to arr3. The output of arr3 should look like this:
arr3(0) = "000 Closed"
arr3(1) = "000 Open"
arr3(2) = "001 Closed"
arr3(3) = "001 Open"
arr3(4) = "002 Closed"
arr3(6) = "002 Open"
arr3(7) = "003 Closed"
arr3(8) = "003 Open"
arr3(9) = "004 Closed"
arr3(10) = "004 Open"
arr3(11) = "005 Closed"
arr3(12) = "005 Open"
I tried this:
Dim arr1(6)
Dim arr2(2)
Dim arr3(0)
Dim i
Dim y
arr1(0) = "This000"
arr1(1) = "This001"
arr1(2) = "This002"
arr1(3) = "This003"
arr1(4) = "This004"
arr1(5) = "This005"
arr2(0) = "Closed"
arr2(1) = "Open"
redim arr3 ((UBound(arr1)) * (Ubound(arr2)))
Console.WriteLine (Ubound (arr3))
for i = Lbound(arr1) to Ubound(arr1)
for y = Lbound(arr2) to Ubound(arr2)
arr3(i*y+y) = (arr1(i) & arr2(y))
next
next
for i = Lbound(arr3) to Ubound(arr3)
Console.WriteLine (arr3(i))
next `
but I can't get it to work properly.
Maybe you guys can help me? thanks
edit:
I now got it kinda working. But i guess there is a more elegant solution to it than this:
Function GetParameters(ByRef arr1, ByRef arr2)
Dim arr3()
Dim i,j,k,l
ReDim Preserve arr3 ((UBound(arr1)+1) * (UBound(arr2)+1)-1)
HMIRuntime.Trace (UBound (arr3)) &vbNewLine
l=0
For i=0 To UBound(arr3)
If i > 0 Then
i=i-1
End If
For j = 0 To UBound (arr2)
For k = 0 To UBound(arr2)
arr3(i) = arr1(l) & " " & arr2(k)
If i < UBound(arr3) Then
i=i+1
End If
Next
If l < (UBound(arr1)) Then
l=l+1
End If
Next
Next
GetParameters=arr3
End Function
edit2: Because resizing the array in the for loop got me into performance issues, I took a second attempt. Here is my final solution (in case somebody else is interested):
Dim arr1()
Dim arr2()
Dim arr3()
Dim i,j,k,l,m,n
Dim maxArr1
Dim maxArr2
maxArr1 = 5 'change for dynamic Arr
maxArr2 = 10
j=0
for l = 0 to maxArr1 'TestArray1
ReDim Preserve arr1(l)
arr1(l) = Cstr(l)
Next
for m = 0 to maxArr2 'TestArray2
ReDim Preserve arr2(m)
arr2(m) ="Closed_"& Cstr(m)
Next
ReDim Preserve arr3( (((Ubound(arr1)+1) * (Ubound(arr2)+1) )-1) ) 'New size for array 3
'Copy arr1 and arr2 in arr3 (according to pattern)
for i=0 to UBound(arr1)
for k=0 to Ubound(arr2)
arr3(j)=arr1(i)& " - "&arr2(k)
j=j+1
Next
Next
For n = 0 To UBound(arr3)
WScript.Echo "arr3("&n&") = "&arr3(n)
Next
Here's a quick attempt based on your code that uses Preserve to maintain the array and build elements dynamically.
Dim arr1(6)
Dim arr2(2)
Dim arr3()
Dim i
Dim y
arr1(0) = "000"
arr1(1) = "001"
arr1(2) = "002"
arr1(3) = "003"
arr1(4) = "004"
arr1(5) = "005"
arr2(0) = "Closed"
arr2(1) = "Open"
Dim item, x
For i = 0 To UBound(arr1) - 1
item = arr1(i)
For y = 0 To UBound(arr2) - 1
x = i + y + 1
ReDim Preserve arr3 (i + x)
arr3(i + x) = item & " " & arr2(y)
Next
Next
For i = 0 To UBound(arr3)
WScript.Echo arr3(i)
Next
Output:
000 Closed
000 Open
001 Closed
001 Open
002 Closed
002 Open
003 Closed
003 Open
004 Closed
004 Open
005 Closed
005 Open
Related
I want to create a function plot_array(arr As Variant) which will create plot based on element in array.
On x axis I want to have numbers 1, 2,.., n which are indexes of array elements, and on y axis I want to have values stored in array. In other words
Example
Dim arr(9) As Variant
arr(0) = 0
arr(1) = 1
arr(2) = 5
arr(3) = 1
arr(4) = 5
arr(5) = 5
arr(6) = 1
arr(7) = 7
arr(8) = 6
plot_array(arr)
I tried to figure it about by running Macros and thinking how can I generalize this code to be working for any array, but I end up with nothing. Is there any possibility how it can be done ?
Try the next code, please. It will create a chart (xlLine type) and feed it with the array. You can change in the line .SeriesCollection.NewSeries.Values = arr1 arr1 with arr and obtain the same thing, if you put all the used number in the range "A1:A9":
Sub testPlotChartArray()
Dim sh As Worksheet, cH As Chart, arr1, arr(1 To 9)
Set sh = ActiveSheet
arr1 = sh.Range("A1:A9").Value
arr(1) = 0: arr(2) = 1: arr(3) = 5: arr(4) = 1: arr(5) = 5
arr(6) = 5: arr(7) = 1: arr(8) = 7: arr(9) = 6
On Error Resume Next
Set cH = sh.ChartObjects("PlotChart").Chart
If Err.Number = 0 Then
Err.Clear
cH.Parent.Delete
End If
On Error GoTo 0
Set cH = sh.ChartObjects.Add(left:=60, top:=10, width:=300, height:=300).Chart
With cH
.Parent.Name = "PlotChart"
.ChartType = xlLine
.SeriesCollection.NewSeries.Values = arr1 'or arr
End With
End Sub
The above code deletes the chart if it exists, but it can be configured to use the same existing chart and feed its .SeriesCollection(1).Values...
If you declare an array as arr(9) in Excel, the index is declared as a total of 10 arrays from 0 to 9, so your array is not the correct number.
Sub test()
Dim arr(8) As Variant
arr(0) = 0
arr(1) = 1
arr(2) = 5
arr(3) = 1
arr(4) = 5
arr(5) = 5
arr(6) = 1
arr(7) = 7
arr(8) = 6
plot_array (arr)
End Sub
Sub plot_array(arr As Variant)
Dim Srs As Series
Dim Cht As Chart
Dim xAxes As Axis, yAxes As Axis
Dim i As Integer, vX() As Variant
ReDim vX(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
vX(i) = i + 1 '<~~ if index start from 0 then delete +1
Next i
Set Cht = ActiveSheet.Shapes.AddChart.Chart
With Cht
.HasTitle = True
.ChartTitle.Text = "My Graph"
.ChartType = xlXYScatterLinesNoMarkers
For Each Srs In .SeriesCollection
Srs.Delete
Next Srs
Set Srs = .SeriesCollection.NewSeries
With Srs
.Name = "item"
.Values = arr
.XValues = vX
.MarkerStyle = xlCircle
End With
Set xAxes = .Axes(xlCategory, xlPrimary)
With xAxes
.MinimumScale = 0
.MaximumScale = WorksheetFunction.Max(vX)
.MajorUnit = 1
.HasMajorGridlines = True
End With
Set yAxes = .Axes(xlValue, xlPrimary)
With yAxes
.MinimumScale = 0
.MaximumScale = WorksheetFunction.Max(arr) + 1
.MajorUnit = 1
.HasMajorGridlines = True
End With
End With
End Sub
I would like to rename worksheets in an exiting workbook. This is the code i am using:
Dim LobArray As Variant
Dim TypeArray As Variant
Dim g As String
'Added during Edit of question.
Dim NoLobs As Long, NoTypes As Long
Dim l As Long, t As Long, s As Long
Dim SheetNames(100) As String
Dim SheetCountSpL As Long
Dim TmplSpl As Workbook
Set TmplSpl = ThisWorkbook
'-----------------------------
g = "_"
LobArray = Array("Lob1", "Lob2", "Lob3", "Lob4")
TypeArray = Array("ea", "pa", "inc")
NoLobs = UBound(LobArray) - LBound(LobArray) + 1
NoTypes = UBound(TypeArray) - LBound(TypeArray) + 1
For l = LBound(LobArray) To UBound(LobArray)
For t = LBound(TypeArray) To UBound(TypeArray)
SheetNames(l * NoLobs + t) = LobArray(l) & g & TypeArray(t)
Next t
Next l
SheetCountSpL = NoTypes * NoLobs
For s = 1 To SheetCountSpL
TmplSpL.Worksheets(s).Activate
TmplSpL.Worksheets(s).Name = SheetNames(s - 1)
Next s
When i reduce the elements in the LobArray to 3 it works. Basically, when the macro has to rename more then 9 sheets, i get the error i mentioned in the title.
This is the code I use to create and rename sheets. It creates sheets based on selected cells and renames the new sheets accordingly. If sheets exist it deletes them
Sub CreateSheetsFromAList()
Dim MyCell As Range
Dim MyRange As Range
Set MyRange = Selection
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
On Error Resume Next
Sheets(Sheets.Count).Name = MyCell.Value 'renames the new worksheet
If Err.Number = 1004 Then
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If
On Error GoTo 0
Next MyCell
End Sub
This is the error:
LobArray = four elements.
TypeArray = three elements.
l = 0, NoLobs = 4, t = 0 on first loop.
First inner loop:
0 * 4 + 0 = 0 = SheetNames(0) = LobArray(0) & TypeArray(0) = "Lob1_ea"
Second inner loop:
0 * 4 + 1 = 1 = SheetNames(1) = .....
Third inner loop:
0 * 4 + 2 = 2 = SheetNames(2) = .....
Fourth inner loop:
Doesn't occur as TypeArray only has 3 elements.
SheetNames(3) is left blank as a result
This code will rename your sheets:
Public Sub Test()
Dim LobArray As Variant
Dim TypeArray As Variant
Dim lobItm As Variant, typeItm As Variant
Dim g As String, x As Long
Dim RequiredSheetCount As Long
g = "_"
LobArray = Array("Lob1", "Lob2", "Lob3", "Lob4")
TypeArray = Array("ea", "pa", "inc")
RequiredSheetCount = (UBound(LobArray) + 1) * (UBound(TypeArray) + 1)
If Worksheets.Count >= RequiredSheetCount Then
For Each lobItm In LobArray
For Each typeItm In TypeArray
x = x + 1
ThisWorkbook.Worksheets(x).Name = lobItm & g & typeItm
Next typeItm
Next lobItm
Else
MsgBox "The workbook needs at least " & RequiredSheetCount & " sheets to work properly."
End If
End Sub
I want to remove the duplicated values of an sorted array.
Here is the code to sort the values in ascending order.
Dim k As Integer
Dim j As Integer
Dim sortedArray As Variant
Dim sorting As Boolean
If sorting = True Then
For j = LBound(concentrationArray) To UBound(concentrationArray)
For k = j + 1 To UBound(concentrationArray)
If concentrationArray(j) < concentrationArray(k) Then
sortedArray = concentrationArray(j)
concentrationArray(j) = concentrationArray(k)
concentrationArray(k) = sortedArray
End If
Next k
Next j
ElseIf sorting = False Then
For j = LBound(concentrationArray) To UBound(concentrationArray)
For k = j + 1 To UBound(concentrationArray)
If concentrationArray(j) > concentrationArray(k) Then
sortedArray = concentrationArray(k)
concentrationArray(k) = concentrationArray(j)
concentrationArray(j) = sortedArray
End If
Next k
Next j
End If
However, from these sorted array, they may contain repeated values which I want to remove them.
For j = LBound(concentrationArray) To UBound(concentrationArray)
For k = j + 1 To UBound(concentrationArray)
If concentrationArray(j) <> concentrationArray(k) Then
sortedArray = concentrationArray(j)
concentrationArray(j) = concentrationArray(k)
concentrationArray(k) = sortedArray
ElseIf concentrationArray(j) = concentrationArray(k) Then
sortedArray = concentrationArray(j)
concentrationArray(j) = concentrationArray(k + 1)
ReDim concentrationArray(LBound(concentrationArray) To UBound(concentrationArray) - 1) As Variant
concentrationArray(k) = sortedArray
End If
Next k
Next j
I don't understand why this returns error.
Can anyone help?
Thanks in advance
--------------------------SOLVED--------------------------
Here it is another way to make it work:
j = LBound(concentrationArray)
While j < UBound(concentrationArray)
If concentrationArray(j) = concentrationArray(j+1) Then
Call DeleteElementArray(j, concentrationArray)
End If
j = j + 1
Wend
Public Sub DeleteElementArray(ByVal arrIndex as Integer, ByRef myArr as Variant)
Dim p as Long
For p = arrIndex+1 To Ubound(myArr)
myArr(p-1) = myArr(p)
Next p
Use this simple trick to make a 1D array unique:
Function Unique(aFirstArray() As Variant)
'Collections can be unique, as long as you use the second Key argument when adding items.
'Key values must always be unique, and adding an item with an existing Key raises an error:
'hence the On Error Resume Next
Dim coll As New Collection, a
Dim tempArray() As Variant 'aFirstArray(),
Dim i As Long
' aFirstArray() = Array("Banana", "Apple", "Orange", "Tomato", "Apple", _
' "Lemon", "Lime", "Lime", "Apple")
On Error Resume Next
For Each a In aFirstArray
'Debug.Print a
coll.Add a, a
Next
ReDim aFirstArray(coll.count)
For i = 1 To coll.count
'Cells(i, 1) = coll(i)
aFirstArray(i) = coll(i)
Next
End Function
As your data is already sorted you could also use an ArrayList object and then extract all items in one go with .toArray. You can use .Contains method to add only unique items.
Option Explicit
Public Sub DeDuplicateArray()
Dim sortedArray(), i As Long, sList As Object, arr()
sortedArray = Array(0, 0, 1, 2, 2, 3)
Set sList = CreateObject("System.Collections.ArrayList")
For i = LBound(sortedArray) To UBound(sortedArray)
If Not sList.contains(sortedArray(i)) Then sList.Add sortedArray(i)
Next
arr = sList.toArray
Debug.Print UBound(arr)
End Sub
If data wasn't sorted you could add to a SortedList object, using a test of .Contains to exclude duplicates.
Option Explicit
Public Sub DeDuplicateArray()
Dim sortedArray(), i As Long, sList As Object
sortedArray = Array(0, 0, 1, 2, 2, 3)
Set sList = CreateObject("System.Collections.SortedList")
For i = LBound(sortedArray) To UBound(sortedArray)
If Not sList.contains(sortedArray(i)) Then sList.Add sortedArray(i), vbNullString
Next
Debug.Print sList.Count
End Sub
try this code please:
Option Explicit
Sub ifDublicate()
Dim i, lRow As Integer
Dim actuellCell, cellInArray As Variant
Dim countValues, deleted As Double
'Dim arr ()
'lRow = ActiveSheet.Range("A" & Range("A:A").Rows.Count).End(xlUp).Row
'arr = Range("A1:A" & lRow)
Dim arr(10) As Variant ' or array from worksheet
arr(0) = "Apple"
arr(1) = "Orange"
arr(2) = "Apple"
arr(3) = "Apple"
arr(4) = "beans"
arr(5) = "beans"
arr(6) = "Orange"
arr(7) = "Orange"
arr(8) = "sandwitch"
arr(9) = "coffee"
arr(10) = "nuts"
For i = 0 To UBound(arr)
actuellCell = arr(i)
If InStr(cellInArray, actuellCell) > 0 Then
' ActiveSheet.Cells(i, 2) = "Already Exists"
deleted = deleted + 1
Else
cellInArray = CStr(cellInArray) & "," & CStr(actuellCell)
countValues = countValues + 1
If Left(cellInArray, 1) = "," Then
cellInArray = Right(cellInArray, Len(cellInArray) - 1)
End If
End If
Next i
MsgBox "Array after remove duplicate: " & cellInArray & vbNewLine & _
"Count Values without duplicate: " & countValues & vbNewLine & _
"deleted: " & deleted & vbNewLine & _
"last value: " & actuellCell
End Sub
I am using Bloomberg sample code to collect data from Bloomberg through VBA (2d array?) and I have some old vba code that I believe takes a normal 3d array (maybe someone can clarify that for me). The problem is that Bloomberg output an array of elements.
See Bloomberg code below. Then below that is what I want to essentially convert the Bloomberg output into something that the next bit of code will accept.
Private Sub session_ProcessEvent(ByVal obj As Object)
On Error GoTo errHandler
Dim eventObj As blpapicomLib2.Event
Set eventObj = obj
If Application.Ready Then
If eventObj.EventType = PARTIAL_RESPONSE Or eventObj.EventType = RESPONSE Then
Dim it As blpapicomLib2.MessageIterator
Set it = eventObj.CreateMessageIterator()
Do While it.Next()
Dim msg As Message
Set msg = it.Message
Dim securityData As Element
Dim securityName As Element
Dim fieldData As Element
Set securityData = msg.GetElement("securityData")
Set securityName = securityData.GetElement("security")
Set fieldData = securityData.GetElement("fieldData")
Sheet1.Cells(currentRow, 4).Value = securityName.Value
Dim b As Integer
For b = 0 To fieldData.NumValues - 1
Dim fields As blpapicomLib2.Element
Set fields = fieldData.GetValue(b)
Dim a As Integer
Dim numFields As Integer
numFields = fields.NumElements
For a = 0 To numFields - 1
Dim field As Element
Set field = fields.GetElement(a)
Sheet1.Cells(currentRow, a + 5).Value = field.Name & " = " & field.Value
Next
currentRow = currentRow + 1
Next b
Loop
' skip a row for next security
currentRow = currentRow + 1
End If
End If
Exit Sub
errHandler:
MsgBox Err.Description
End Sub
This is the next bit of code I want the Bloomberg output to feed into.
Option Explicit
Dim Count() As Variant
Dim AdjCount() As Variant
Dim Rev() As Variant
Dim Conf() As Variant
Dim ncount() As Integer
Sub CreateSetupsBUY(series As Variant)
Dim x As Integer
Dim Y As Integer
Dim temp1 As Variant
Dim temp2 As Variant
Dim temp3 As Variant
Dim temp4 As Integer
Dim temp5 As Variant
ReDim Count(UBound(series))
ReDim AdjCount(UBound(series))
ReDim Rev(UBound(series))
ReDim Confn(UBound(series))
ReDim ncount(UBound(series))
For x = LBound(series) To UBound(series)
ReDim temp1(UBound(series(x)))
ReDim temp2(UBound(series(x)))
ReDim temp3(UBound(series(x)))
temp4 = 0
ReDim temp5(UBound(series(x)))
For Y = LBound(series(x)) + 5 To UBound(series(x))
If IsNumeric(series(x)(Y, 1)) Then
If series(x)(Y, 4) < series(x)(Y - 4, 4) Then
temp1(Y) = 1 + temp1(Y - 1)
Else
temp1(Y) = 0
End If
If series(x)(Y, 4) > series(x)(Y - 4, 4) Then
temp5(Y) = 1 + temp5(Y - 1)
Else
temp5(Y) = 0
End If
If temp1(Y) > 9 Then
temp2(Y) = 0
Else
temp2(Y) = temp1(Y)
End If
If temp1(Y) = 9 Then
temp4 = temp4 + 1
End If
If series(x)(Y - 1, 4) >= series(x)(Y - 5, 4) Then
temp3(Y) = 1
Else
temp3(Y) = 0
End If
Else
temp1(Y) = 0
temp2(Y) = 0
temp3(Y) = 0
temp4 = 0
temp5(Y) = 0
End If
Next Y
Count(x) = temp1
AdjCount(x) = temp2
Conf(x) = temp3
ncount(x) = temp4
Rev(x) = temp5
Next x
Call CreateCount(series, Count, Conf, ncount, Rev)
End Sub
When I tried connecting the two I get a type error. I assume its because of the way the Bloomberg array is created and unpacked.
Possible solution I have yet to try is to unpack the Bloomberg array and some how build a basic column row array while the Bloomberg array is unpacking.
Can any one has an idea about how to find an integer from an array of integers in vb6?
Dim myArray(2) As Integer
myArray(1) = 1001
myArray(2) = 1002
Dim searchTerm As Integer
searchTerm = 1005
Dim flag As Boolean
flag = True
Dim temp As Variant
For Each temp In myArray
If temp = searchTerm Then
flag = False
End If
Next temp
If flag = False Then
MsgBox "find"
End If
I got the solution by using For Each statement , but i want the solution using Do..Loop ??
Edit
Dim myArray(2) As Integer
myArray(0) = 1000
myArray(1) = 1001
myArray(2) = 1002
'Initialise Search Term
Dim searchTerm As Integer
searchTerm = 1001
'Check if a value exists in the Array
If UBound(Filter(myArray, searchTerm)) >= 0 And searchTerm <> "" Then
MsgBox ("Search Term SUCCESSFULLY located in the Array")
Else
MsgBox ("Search Term could NOT be located in the Array")
End If
You can simply:
Dim i As Integer, found As Boolean
Do While i <= UBound(myArray) And Not found
If (myArray(i) = searchTerm) Then
found = True
Else
i = i+1
End If
Loop
If (found) Then Msgbox "found # " & i
The below code works file
Dim myArray(2) As Integer
myArray(0) = 1000
myArray(1) = 1001
myArray(2) = 1002
Dim searchTerm As Integer
searchTerm = 1005
Dim flag As Boolean
flag = True
Dim i As Integer
Dim lb As Integer
Dim hb As Integer
lb = LBound(myArray)
hb = UBound(myArray)
Do While (lb < hb)
Dim j As Integer
If searchTerm = myArray(j) Then
flag = False
End If
j = j + 1
lb = lb + 1
Loop
If flag = False Then
MsgBox "find"
Else
MsgBox "not find"
End If