I have following code:
Sub nummm()
Dim num() As String
For x = 2 To 1000
c = 0
ReDim Preserve num(UBound(Split(Cells(x, 7).Value, " ")) + 1)
num = Split(Cells(x, 7).Value, " ")
For Each b In num
c = c + 1
If c = UBound(num) + 1 Then GoTo vv:
Next
vv:
Next
End Sub
It's running fine if I remove line
If c = UBound(num) + 1 Then GoTo vv:
but if it's not removed, I get run-time error: "This array is fixed or temporarily locked"
How can I make variable num dynamic?
thx for help
I don't know how your b and other variables (except num) are declared but maybe this could help you:
Sub nummm()
Dim num As Variant 'So you can directly assign the array from Split
For x = 2 To 1000
c = 0
num = Split(Cells(x, 7).Value, " ")
For Each b In num
c = c + 1
'Rather than "GoTo somewhere", "Exit For" will exit the current For loop
If c = UBound(num) + 1 Then Exit For
Next b
Next x
End Sub
Related
I'm trying to find the values in different points of the array. When I run the code, it always goes to The value doesn't exists, also I do not know how to count the values that are same r.
r = 0
c = txtbbus.Text
For i = 0 To n - 1
For j = 0 To n - 1
If a(i, j) = c Then
txtbres.Text = "The value exists " & r & " and it's in the position (" & i & ", " & j & ") "
Else
txtbres.Text = "The value doesn't exists"
End If
Next j
Next i
And this is how I initialize a:
txtbmatriz.Text = ""
For i = 0 To n - 1
For j = 0 To n - 1
a(i, j) = CInt((100 * Rnd()) + 1)
txtbmatriz.Text += a(i, j) & " "
m += a(i, j)
l += 1
Next j
txtbmatriz.Text += vbCrLf
Next i
The problem is almost certainly that you don't break out of the loop when you find a match. Your code will only ever show you the result of the last element in the array because you always keep searching to the last element. Once you find a match, there's no point to looking further and, in fact, doing so is detrimental. Once you find a match, stop looking.
Finding a single/first match:
Dim rng As New Random
Dim matrix = New Integer(9, 9) {}
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
matrix(i, j) = rng.Next(1, 101)
Next
Next
Dim target = rng.Next(1, 101)
Dim message As String
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
If matrix(i, j) = target Then
message = $"{target} found at ({i},{j})"
Exit For
End If
Next
If message IsNot Nothing Then
Exit For
End If
Next
Console.WriteLine(If(message, $"{target} not found"))
Finding all matches:
Dim rng As New Random
Dim matrix = New Integer(9, 9) {}
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
matrix(i, j) = rng.Next(1, 101)
Next
Next
Dim target = rng.Next(1, 101)
Dim matches As New List(Of String)
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
If matrix(i, j) = target Then
matches.Add($"({i},{j})")
End If
Next
Next
Console.WriteLine(If(matches.Any(),
$"{target} found at {String.Join(", ", matches)}",
$"{target} not found"))
Try this:
r = 0
c = txtbbus.Text
Dim i As Integer
Dim j As Integer
Dim FoundMatch As Boolean = False
For i = 0 To n - 1
For j = 0 To n - 1
If a(i, j) = c Then
FoundMatch = True
Exit For
End If
Next j
If FoundMatch = True Then
Exit For
End If
Next i
If FoundMatch = True Then
txtbres.Text = "The value exists " & r & " and it's in the position (" & i & ", " & j & ") "
Else
txtbres.Text = "The value doesn't exists"
End If
I'm going to assume c = txtbbus.Text is from some form input. Meaning a string. For the equality check you'd be testing against an Int type. Try casting the input from txtbbus.Text as an integer. Also, like the other poster said breaking from the loop on finding your match would also be a good decision.
I need to build a list of superscripts in a document which is fine until I get to symbols for things like partial derivatives which instead return as ? in my array instead of ∂. What could I add to capture the actual symbol? Thanks
Dim i As Long, j As String
Dim txtboxString() As String
Dim Superscript As String
Dim myrange As range
Dim ap As Document: Set ap = ActiveDocument
x = 0
For i = 1 To ap.Characters.Count
j = ""
If ActiveDocument.Characters(i).Font.Superscript = True Then
Z = 0
ReDim Preserve txtboxString(x + 1)
For Z = i To i - 5 Step -1
If Z > ap.Characters.Count Then GoTo 1
If ActiveDocument.Characters(Z) = "," Then GoTo 0
If ActiveDocument.Characters(Z).Font.Superscript = True Then j = ActiveDocument.Characters(Z) & j
Next Z
End If
0: If j <> "" Then
If j <> "," Then
If j <> "?" Then
txtboxString(x) = j
x = x + 1
End If
End If
End If
If Z + 1 > ap.Characters.Count Then i = Z 'Else i = Z + 1
Set myrange = ActiveDocument.Characters(i + 1)
myrange.MoveUntil Cset:="* "
i = myrange.End - 1
Next
Hi my code currently looks like this
Sub Solbjerg()
Set i = Sheets("Samlet")
Set e = Sheets("ABC")
Dim d
Dim j
d = 7
j = 7
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) = "Cinema ABC" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
However sometimes the data i get is not always "Cinema ABC" but just "ABC". So i need my code to search if the data contains "ABC" instead of equals to "Cinema ABC".
Can you guys help me?
Change
If i.Range("A" & j) = "Cinema ABC" Then
to
If InStr(1, i.Range("A" & j), "ABC") Then
Sub Solbjerg()
Set i = Sheets("Samlet")
Set e = Sheets("ABC")
Dim d
Dim j
d = 7
j = 7
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) like "*ABC" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
Like, and * works as wildcards
I was wondering why the following syntax does not work the way I thought it would in VBA, and what I should do to ensure it does;
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
If a <> b <> c Then
MsgBox (a & " " & b & " " & c)
End If
Next c
Next b
Next a
This is a simplified example, which can still be manually obtained with:
if a<>b and b<>c and c<>a then
But my actual intended code has 10 such variables multiple times, which makes it unfeasible with 55 unequal conditions, or likely for me to make a typo. I think there is a more efficient way but I have not found it.
Ps. My goal is to only have a message box pop up if all the variables are unique.
I have obtained my goal, though it can probably be done much more efficient than:
For a = 1 To 10
check(a) = True
For b = 1 To 10
If check(b) = False Then
check(b) = True
For c = 1 To 10
If check(c) = False Then
check(c) = True
For d = 1 To 10
If check(d) = False Then
check(d) = True
For e = 1 To 10
If check(e) = False Then
check(e) = True
MsgBox (a & " " & b & " " & c & " " & d & " " & e)
End If
check(e) = False
check(a) = True
check(b) = True
check(c) = True
check(d) = True
Next e
End If
check(d) = False
check(a) = True
check(b) = True
check(c) = True
Next d
End If
check(c) = False
check(a) = True
check(b) = True
Next c
End If
check(b) = False
check(a) = True
Next b
Next a
Here is an implementation of the Johnson-Trotter algorithm for enumerating permutations. It is a small modification of one that I wrote once when playing around with brute-force solutions to the Traveling Salesman Problem. Note that it returns a 2-dimensional array, which might consume a lot of memory. It is possible to refactor it so that it is a sub where the permutations are consumed rather than stored. Just replace the part of the code near the bottom (where the current permutation, perm, is stored in the array perms) by the code that uses the permutation.
Function Permutations(n As Long) As Variant
'implements Johnson-Trotter algorithm for
'listing permutations. Returns results as a variant array
'Thus not feasible for n > 10 or so
Dim perm As Variant, perms As Variant
Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long
Dim p_i As Long, p_j As Long
Dim state As Variant
m = Application.WorksheetFunction.Fact(n)
ReDim perm(1 To n)
ReDim perms(1 To m, 1 To n) As Integer
ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm
'state(i,2) = direction of i
k = 1 'will point to current permutation
For i = 1 To n
perm(i) = i
perms(k, i) = i
state(i, 1) = i
state(i, 2) = -1
Next i
state(1, 2) = 0
i = n 'from here on out, i will denote the largest moving
'will be 0 at the end
Do While i > 0
D = state(i, 2)
'swap
p_i = state(i, 1)
p_j = p_i + D
j = perm(p_j)
perm(p_i) = j
state(i, 1) = p_j
perm(p_j) = i
state(j, 1) = p_i
p_i = p_j
If p_i = 1 Or p_i = n Then
state(i, 2) = 0
Else
p_j = p_i + D
If perm(p_j) > i Then state(i, 2) = 0
End If
For j = i + 1 To n
If state(j, 1) < p_i Then
state(j, 2) = 1
Else
state(j, 2) = -1
End If
Next j
'now find i for next pass through loop
If i < n Then
i = n
Else
i = 0
For j = 1 To n
If state(j, 2) <> 0 And j > i Then i = j
Next j
End If
'record perm in perms:
k = k + 1
For r = 1 To n
perms(k, r) = perm(r)
Next r
Loop
Permutations = perms
End Function
Tested like:
Sub test()
Range("A1:G5040").Value = Permutations(7)
Dim A As Variant, i As Long, s As String
A = Permutations(10)
For i = 1 To 10
s = s & " " & A(3628800, i)
Next i
Debug.Print s
End Sub
The first 20 rows of output look like:
Also, 2 1 3 4 5 6 7 8 9 10 is printed in the immediate window. My first version used a vanilla variant away and caused an out-of-memory error with n = 10. I tweaked it so that perms is redimensioned to contain integers (which consume less memory than variants) and is now able to handle 10. It takes about 10 seconds on my machine to run the test code.
You could simply add a check right after the beginning of each inner loop, like follows
For a = 1 To 10
For b = 1 To 10
If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables
For c = 1 To 10
If c <> b Then '<-- same comment as preceeding one
For d = 1 to 10
If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables
Next d
End If
Next c
End If
Next b
Next a
Try putting all those variables into the array and checking the array for duplicates, if none found, display the message box. Something like this:
Sub dupfind()
Dim ArrHelper(2) As Long
Dim k As Long
Dim j As Long
Dim ans As Long
Dim dupl As Boolean
Dim ArrAnswers() As Long
ans = 0
For a = 1 To 10
ArrHelper(0) = a
For b = 2 To 10
ArrHelper(1) = b
For c = 1 To 10
ArrHelper(2) = c
dupl = False
For k = 0 To UBound(ArrHelper) - 1
For j = k + 1 To UBound(ArrHelper)
If ArrHelper(k) = ArrHelper(j) Then
dupl = True
End If
Next j
Next k
If dupl = False Then
ReDim Preserve ArrAnswers(3, ans)
ArrAnswers(0, ans) = a
ArrAnswers(1, ans) = b
ArrAnswers(2, ans) = c
ans = ans + 1
End If
Next c
Next b
Next a
End Sub
Read your edit regarding storing permutations and changed the code a bit
I looked through the questions here and though there is a lot of stuff about matching similar strings with the instr function etc, there isn't much about exact matching.
I'm looping through a list of names classified by id where each id has its own corresponding benchmark. Unfortunately all the benchmark names are something along the lines of "Barclays" x Index where there are a ton of similar sounding names such as Barclays US Aggregate Index, Barclays Intermediate Us Aggregate Index etc... and just trying to match gives an output.. but the wrong data points. Here is my code for reference.. the issue is in 2nd elseif of the loop.
I was wondering if there is an easy method to resolve this.
For i = 1 To lastrow
Sheets(source).Activate
If source = "Historical" Then
If Range("A" & i).Value = delimit2 Then
benchmark_name = Sheets(source).Range("L" & i).Value
j = j + 10
name = Sheets(source).Range("A" & i + 1).Value
Sheets(output_sht).Range("D" & j - 3) = "Portfolio"
Sheets(output_sht).Range("E" & j - 3) = benchmark_name
ElseIf benchmark_name <> vbNullString _
And Range("A" & i).Value = benchmark_name Then
If IsNumeric(Sheets(source).Range("F" & i).Value) Then
Alt_return3 = Sheets(source).Range("F" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j, col1)) Then
Sheets(output_sht).Cells(j, col1) = Alt_return3 / 100
End If
End If
If IsNumeric(Sheets(source).Range("G" & i).Value) Then
Alt_return5 = Sheets(source).Range("G" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j + 1, col1)) Then
Sheets(output_sht).Cells(j + 1, col1) = Alt_return5 / 100
End If
End If
'
If IsNumeric(Sheets(source).Range("H" & i).Value) Then
Alt_returnINC = Sheets(source).Range("H" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j + 2, col1)) Then
Sheets(output_sht).Cells(j + 2, col1) = Alt_returnINC / 100
End If
Sheets(output_sht).Range("D" & j & ":E" & j + 5).NumberFormat = "0.00%"
End If
Sheets(output_sht).Range("C" & j) = period
Sheets(output_sht).Range("C" & j + 1) = period2
Sheets(output_sht).Range("C" & j + 2) = period3
Else
End If
End If
Next i
Comment as answer because I cannot comment:
Aren't you looking for the Like operator?
And you should add to the top of your code: Option compare text
More info on the like operator
I know you are looking for an exact match. However you may want to consider trying a FuzzyMatch.
http://code.google.com/p/fast-vba-fuzzy-scoring-algorithm/source/browse/trunk/Fuzzy1
You can download/import this function to your workbook and then call it with the 2 strings/names you are comparing and it will return a score.
If I were you I'd loop through all the possible names and take the highest score.
Which in your case would be 100% if you are looking for an exact match.
This will add time to your procedure but it might help you.
===EDITED
========= Here is the code. Add this to your Module.
Option Explicit
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
'To be placed in the Declarations area
'_____________________________________
Sub TestFuzzy()
Dim t As Long, a As Long, i As Long
t = GetTickCount
For i = 1 To 100000
a = Fuzzy("Sorin Sion", "Open Source")
Next
Debug.Print "Similarity score: " & a & "; " & i - 1 & " iterations took " & _
GetTickCount - t & " milliseconds"
End Sub
'TestFuzzy's result should look like:
'Similarity score: 0.3; 100000 iterations took 2094 milliseconds
'The test was done on an Intel processor at 3.2GHz
'_____________________________________
Public Function Fuzzy(ByVal s1 As String, ByVal s2 As String) As Single
Dim i As Integer, j As Integer, k As Integer, d1 As Integer, d2 As Integer, p As Integer
Dim c As String, a1 As String, a2 As String, f As Single, o As Single, w As Single
'
' ******* INPUT STRINGS CLEANSING *******
'
s1 = UCase(s1) 'input strings are converted to uppercase
d1 = Len(s1)
j = 1
For i = 1 To d1
c = Mid(s1, i, 1)
Select Case c
Case "0" To "9", "A" To "Z" 'filter the allowable characters
a1 = a1 & c 'a1 is what remains from s1 after filtering
j = j + 1
End Select
Next
If j = 1 Then Exit Function 'if s1 is empty after filtering
d1 = j - 1
s2 = UCase(s2)
d2 = Len(s2)
j = 1
For i = 1 To d2
c = Mid(s2, i, 1)
Select Case c
Case "0" To "9", "A" To "Z"
a2 = a2 & c
j = j + 1
End Select
Next
If j = 1 Then Exit Function
d2 = j - 1
k = d1
If d2 < d1 Then
'to prevent doubling the code below s1 must be made the shortest string,
'so we swap the variables
k = d2
d2 = d1
d1 = k
s1 = a2
s2 = a1
a1 = s1
a2 = s2
Else
s1 = a1
s2 = a2
End If
If k = 1 Then 'degenerate case, where the shortest string is just one character
If InStr(1, s2, s1, vbBinaryCompare) > 0 Then
Fuzzy = 1 / d2
Else
Fuzzy = 0
End If
Else '******* MAIN LOGIC HERE *******
i = 1
f = 0
o = 0
Do 'count the identical characters in s1 and s2 ("frequency analysis")
p = InStr(1, s2, Mid(s1, i, 1), vbBinaryCompare)
'search the character at position i from s1 in s2
If p > 0 Then 'found a matching character, at position p in s2
f = f + 1 'increment the frequency counter
s2 = Left(s2, p - 1) & "~" & Mid(s2, p + 1)
'replace the found character with one outside the allowable list
'(I used tilde here), to prevent re-finding
Do 'check the order of characters
If i >= k Then Exit Do 'no more characters to search
If Mid(s2, p + 1, 1) = Mid(s1, i + 1, 1) Then
'test if the next character is the same in the two strings
f = f + 1 'increment the frequency counter
o = o + 1 'increment the order counter
i = i + 1
p = p + 1
Else
Exit Do
End If
Loop
End If
If i >= k Then Exit Do
i = i + 1
Loop
If o > 0 Then o = o + 1 'if we got at least one match, adjust the order counter
'because two characters are required to define "order"
finish:
w = 2 'Weight of characters order match against characters frequency match;
'feel free to experiment, to get best matching results with your data.
'If only frequency is important, you can get rid of the second Do...Loop
'to significantly accelerate the code.
'By altering a bit the code above and the equation below you may get rid
'of the frequency parameter, since the order counter increments only for
'identical characters which are in the same order.
'However, I usually keep both parameters, since they offer maximum flexibility
'with a variety of data, and both should be maintained for this project
Fuzzy = (w * o + f) / (w + 1) / d2
End If
End Function
==================
So once you have it then just add something like this.
Dim strA, strB, hiScore(1 to 3), tempScore
With Thisworkbook.ActiveSheet
For a = 1 to .Usedrange.Rows.Count ' Scans Column 1
strA = .cells(a,1) ' Barclays Aggregate Index
For b = 1 to .usedrange.rows.count ' Compares Col 1 to Col 2
strB = .cells(b,2) ' Barclays Aggregate Other Index
tempScore = Fuzzy(strA, strB)
If tempScore > hiScore then
hiScore(1) = tempScore
hiScore(2) = a
hiScore(3) = b
End If
Next b
' Do your Action with the Best Match Here
If hiScore(1) = 1 then ' (100% - perfect match)
' Copies col 3 from the row that the best strB match was on
' to col 4 from the row strA was on
.Cells(a,4) = .Cells(hiScore(3),3)
End If
' ====
' Reset Variables
hiScore = ""
tempScore = ""
Next a
End with