So I am writing code that will read in weather data from a file. What I have now is a function that can read it in if there is only integers in the file and nothing to label it. Here is an example of my file:
January
2015
High Low precip Snow Forecast Avg. Hi Avg. Lo
Thu
1/1/2015 40° 14° 0 in 0 in Cloudy 38° 23°
Fri
1/2/2015 42° 23° 0 in 0 in Cloudy 38° 23°
Sat
1/3/2015 36° 21° 0.58 in 0 in Cloudy 38° 23°
I have to read in the High/Low temps and the avg high/low temps. Here is the function I have down that could read in the file if there was only the numbers I need and no labeling:
Public Sub getNext4Ints(ByRef int1 As Integer, ByRef int2 As Integer, ByRef int3 As Integer, ByRef int4 As Integer)
int1 = getNextInteger()
int2 = getNextInteger()
int3 = getNextInteger()
int4 = getNextInteger()
End Sub
Public Function getNextInteger() As Integer
Dim charInt As String
Dim chr As String
Static index As Integer = -1
index += 1
chr = numDat(index)
While Asc(chr) < 48 Or Asc(chr) > 57
index += 1
chr = numDat(index)
End While
charInt = chr
While Asc(chr) >= 48 And Asc(chr) <= 57
index += 1
chr = numDat(index)
charInt += chr
End While
Return CInt(charInt)
End Function
Basically I am having trouble with only reading in what I need and skipping over the labels such as the date, precip, snow, and forecast. Sorry I am new to vb and can't seem to get around this. Thank you.
Related
I want to take a number and convert it into lowercase a-z letters using VBScript.
For example:
1 converts to a
2 converts to b
27 converts to aa
28 converts to ab
and so on...
In particular I am having trouble converting numbers after 26 when converting to 2 letter cell names. (aa, ab, ac, etc.)
You should have a look at the Chr(n) function.
This would fit your needs from a to z:
wscript.echo Chr(number+96)
To represent multiple letters for numbers, (like excel would do it) you'll have to check your number for ranges and use the Mod operator for modulo.
EDIT:
There is a fast food Copy&Paste example on the web: How to convert Excel column numbers into alphabetical characters
Quoted example from microsoft:
For example: The column number is 30.
The column number is divided by 27: 30 / 27 = 1.1111, rounded down by the Int function to "1".
i = 1
Next Column number - (i * 26) = 30 -(1 * 26) = 30 - 26 = 4.
j = 4
Convert the values to alphabetical characters separately,
i = 1 = "A"
j = 4 = "D"
Combined together, they form the column designator "AD".
And its code:
Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function
Neither of the solutions above work for the full Excel range from A to XFD. The first example only works up to ZZ. The second example has boundry problems explained in the code comments below.
//
Function ColumnNumberToLetter(ColumnNumber As Integer) As String
' convert a column number to the Excel letter representation
Dim Div As Double
Dim iMostSignificant As Integer
Dim iLeastSignificant As Integer
Dim Base As Integer
Base = 26
' Column letters are base 26 starting at A=1 and ending at Z=26
' For base 26 math to work we need to adjust the input value to
' base 26 starting at 0
Div = (ColumnNumber - 1) / Base
iMostSignificant = Int(Div)
' The addition of 1 is needed to restore the 0 to 25 result value to
' align with A to Z
iLeastSignificant = 1 + (Div - iMostSignificant) * Base
' convert number to letter
ColumnNumberToLetter = Chr(64 + iLeastSignificant)
' if the input number is larger than the base then the conversion we
' just did is the least significant letter
' Call the function again with the remaining most significant letters
If ColumnNumber > Base Then
ColumnNumberToLetter = ColumnNumberToLetter(iMostSignificant) & ColumnNumberToLetter
End If
End Function
//
try this
function converts(n)
Dim i, c, m
i = n
c = ""
While i > 26
m = (i mod 26)
c = Chr(m+96) & c
i = (i - m) / 26
Wend
c = Chr(i+96) & c
converts = c
end function
WScript.Echo converts(1000)
Okay so in visual basic I am trying to read in from a file and the only things I need to read in are all the strings that have a ° at the end of it because it is a temperature. So far I have it so integers will be read in but I dont know how to make it check if there is a ° at the end of it. Here is what I have:
Public Function getNextInteger() As Integer
Dim charInt As String
Dim chr As String
Static index As Integer = -1
index += 1
chr = numDat(index)
While Asc(chr) < 48 Or Asc(chr) > 57
index += 1
chr = numDat(index)
End While
charInt = chr
While Asc(chr) >= 48 And Asc(chr) <= 57
index += 1
chr = numDat(index)
charInt += chr
End While
Return CInt(charInt)
End Function
thanks!
Did you mean this?
Dim txt As String
txt = "55°"
If Len(txt) > 0 And Right(txt, 1) = "°" Then MsgBox "° found"
If Len(txt) > 0 And Asc(Right(txt, 1)) = 176 Then MsgBox "° found"
I am looking for a simple algorithm which works on the following table:
In the first column you see the constraints. The second column should be used by the algorithm to output the iterations, which should be done like this:
0 0 0
0 0 1
........
0 0 29
0 1 0
........
0 1 29
0 2 0
0 2 1
........
........
27 9 29
28 0 0
........
........
28 9 29
Currently I have the following code:
Dim wksSourceSheet As Worksheet
Set wksSourceSheet = Worksheets("Solver")
Dim lngLastRow As Long
Dim lngLastColumn As Long
With wksSourceSheet
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
lngLastColumn = IIf(IsEmpty(.Cells(1, .Columns.Count)), _
.Cells(1, .Columns.Count).End(xlToLeft).Column, .Columns.Count)
Dim intRowOuter As Integer
Dim intRowInner As Integer
For intRowOuter = 2 To lngLastRow
.Cells(intRowOuter, lngLastColumn).Value = 0
Next intRowOuter
For intRowOuter = lngLastRow To 2 Step -1
For intRowInner = lngLastRow To intRowOuter Step -1
Dim constraint As Integer
Dim intConstraintCounter As Integer
intConstraint = .Cells(intRowInner, 1)
For intConstraintCounter = 1 To intConstraint
.Cells(intRowInner, lngLastColumn).Value = intConstraintCounter
Next intStampCounter
Next intRowInner
Next intRowOuter
End With
This might be a right approach but something is incorrect. I'm unfortunately stuck so I would appreciate some help on fixing this.
Solution
I would suggest using one array to store the constraints and one to represent the counter.
Dim MaxNum() As Long
Dim myCounter() As Long
ReDim MaxNum(1 To NumDigits)
ReDim myCounter(1 To NumDigits)
Next you need to initialize MaxNum. This will probably involve looping through the cells containing the constraints. Something like:
Dim constraintRange As Range
Dim i As integer
Set constraintRange = wksSourceSheet.Range("A2:A4")
For i = 1 to numDigits
MaxNum(i) = constraintRange.Cells(i,1).Value
Next i
Now we just need to write an increment counter function! The idea is pretty simple we just go from the least significant digit to the most significant. We increment the LSD and, if there is overflow we set it to 0 and then add 1 to the next digit. It looks like this:
Sub IncrNum(ByRef myNum() As Long, ByRef MaxNum() As Long)
Dim i As Integer
For i = LBound(myNum) To UBound(myNum)
myNum(i) = myNum(i) + 1
If myNum(i) > MaxNum(i) Then 'Overflow!
myNum(i) = 0 'Reset digit to 0 and continue
Else
Exit For 'No overflow so we can just exit
End If
Next i
End Sub
Which is just one for-loop! I think this will be the cleanest solution :)
NOTE: To use this function you would simply do IncrNum(myCounter, MaxNum). Which would change the value of myCounter to the next in the sequence. From here you can paste to a range by doing dstRange = myCounter.
Testing
In my own tests I used a while loop to print out all of the values. It looked something like this:
Do While Not areEqual(MaxNum, myCounter)
Call IncrNum(myCounter,MaxNum)
outRange = myCounter
Set outRange = outRange.Offset(1, 0)
Loop
areEqual is just a function which returns true if the parameters contain the same values. If you like I can provide my code otherwise I will leave it out to keep my answer as on track as it can be.
Maybe something like this can be modified to fit your needs. It simulates addition with carry:
Sub Clicker(MaxNums As Variant)
Dim A As Variant
Dim i As Long, j As Long, m As Long, n As Long
Dim sum As Long, carry As Long
Dim product As Long
m = LBound(MaxNums)
n = UBound(MaxNums)
product = 1
For i = m To n
product = product * (1 + MaxNums(i))
Next i
ReDim A(1 To product, m To n)
For j = m To n
A(1, j) = 0
Next j
For i = 2 To product
carry = 1
For j = n To m Step -1
sum = A(i - 1, j) + carry
If sum > MaxNums(j) Then
A(i, j) = 0
carry = 1
Else
A(i, j) = sum
carry = 0
End If
Next j
Next i
Range(Cells(1, 1), Cells(product, n - m + 1)).Value = A
End Sub
Used like:
Sub test()
Clicker Array(3, 2, 2)
End Sub
Which produces:
x%10 or x Mod 10 give the remainder when x is divided by 10 so you will get the last digit of x.
Since your problem is specifically asking for each digit not to exceed 463857. You can have a counter incrementing from 000000 to 463857 and only output/use the numbers the fullfill the following condition:
IF(x%10 <= 7 AND x%100 <=57 AND x%1000 <= 857 AND x%10000 <=3857 AND x%100000 <= 63857 AND x <= 463857)
THEN //perform task.
This function lets you find similar strings from a range without having to do an exact search.
The formula looks like this: =FuzzyFind(A1,B$1:B$20)
assuming the string you are performing a search for is in A1
and your reference or options table is B1:B20
The code is here:
Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
str = cell
For i = 1 To Len(lookup_value)
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
a = a + 1
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
Next i
a = a - Len(cell)
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind = Value
End Function
The results from this function are hit and miss. Can anyone improve the intelligence of this algorithm?
Thank you :)
I'm not sure exactly what "FuzzyFind" entails, but this is a VLOOKUP that uses the Levenshtein distance to find similar data.
The Levenshtein distance lets you select a "percentage match" that you can specify instead of the typical TRUE or FALSE from a normal VLOOKUP:
Usage is: DTVLookup(A1,$C$1:$C$100,1,90) where 90 is the Levenshtein Distance.
DTVLookup(Value To Find, Range to Search, Column to Return, [Percentage Match])
I typically use this when comparing names that come from different databases like:
Correct Name Example Lookup Percentage Match Other Report
John S Smith John Smith 83 John Smith
Barb Jones Barbara Jones 77 Barbara Jones
Jeffrey Bridge Jeff Bridge 79 Jeff Bridge
Joseph Park Joseph P. Park 79 Joseph P. Park
Jefrey Jones jefre jon 75 jefre jon
Peter Bridge peter f. bridge 80 peter f. bridge
Here's the code:
Function DTVLookup(TheValue As Variant, TheRange As Range, TheColumn As Long, Optional PercentageMatch As Double = 100) As Variant
If TheColumn < 1 Then
DTVLookup = CVErr(xlErrValue)
Exit Function
End If
If TheColumn > TheRange.Columns.Count Then
DTVLookup = CVErr(xlErrRef)
Exit Function
End If
Dim c As Range
For Each c In TheRange.Columns(1).Cells
If UCase(TheValue) = UCase(c) Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
ElseIf PercentageMatch <> 100 Then
If Levenshtein3(UCase(TheValue), UCase(c)) >= PercentageMatch Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
End If
End If
Next c
DTVLookup = CVErr(xlErrNA)
End Function
Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long
Dim i As Long, j As Long, string1_length As Long, string2_length As Long
Dim distance(0 To 60, 0 To 50) As Long, smStr1(1 To 60) As Long, smStr2(1 To 50) As Long
Dim min1 As Long, min2 As Long, min3 As Long, minmin As Long, MaxL As Long
string1_length = Len(string1): string2_length = Len(string2)
distance(0, 0) = 0
For i = 1 To string1_length: distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): Next
For j = 1 To string2_length: distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): Next
For i = 1 To string1_length
For j = 1 To string2_length
If smStr1(i) = smStr2(j) Then
distance(i, j) = distance(i - 1, j - 1)
Else
min1 = distance(i - 1, j) + 1
min2 = distance(i, j - 1) + 1
min3 = distance(i - 1, j - 1) + 1
If min2 < min1 Then
If min2 < min3 Then minmin = min2 Else minmin = min3
Else
If min1 < min3 Then minmin = min1 Else minmin = min3
End If
distance(i, j) = minmin
End If
Next
Next
' Levenshtein3 will properly return a percent match (100%=exact) based on similarities and Lengths etc...
MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length
Levenshtein3 = 100 - CLng((distance(string1_length, string2_length) * 100) / MaxL)
End Function
Try this out, I think it will find the best match
Function FuzzyFind2(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = cell
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, lookup_value) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, lookup_value) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind2 = Value
End Function
I've been looking for this theme a lot and definitely Holmes IV answer is the best. I would just add a small update to compare always in uppercase. For my problems it recommended me more accurate options.
Function FuzzyFind3(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = UCase(cell)
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, UCase(lookup_value)) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, UCase(lookup_value)) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind3 = Value
I want a function to calculate numerology.For example if i enter "XYZ" then my output should be 3 .
Here is how it became 3:
X = 24
Y = 25
Z = 26
on adding it becomes 75 which again adds up to 12 (7+5) which again adds up to 3(1+2) . Similarly whatever names i should pass,my output should be a single digit score.
Here you are:
Function Numerology(Str)
Dim sum, i, char
' Convert the string to upper case, so that 'X' = 'x'
Str = UCase(Str)
sum = 0
' For each character, ...
For i = 1 To Len(Str)
' Check if it's a letter and raise an exception otherwise
char = Mid(Str, i , 1)
If char < "A" Or char > "Z" Then Err.Raise 5 ' Invalid procedure call or argument
' Add the letter's index number to the sum
sum = sum + Asc(char) - 64
Next
' Calculate the result using the digital root formula (http://en.wikipedia.org/wiki/Digital_root)
Numerology = 1 + (sum - 1) Mod 9
End Function
In vbscript:
Function numerology(literal)
result = 0
for i = 1 to Len(literal)
'' // for each letter, take its ASCII value and substract 64,
'' so "A" becomes 1 and "Z" becomes 26
result = result + Asc(Mid(literal, i, 1)) - 64
next
'' // while result is bigger than 10, let's sum it's digits
while(result > 10)
partial = 0
for i = 1 to Len(CStr(result))
partial = partial + CInt(Mid(CStr(result), i, 1))
next
result = partial
wend
numerology = result
End Function
I have no idea what this could possible be used for but it was fun to write anyway.
Private Function CalcStupidNumber(ByVal s As String) As Integer
s = s.ToLower
If (s.Length = 1) Then 'End condition
Try
Return Integer.Parse(s)
Catch ex As Exception
Return 0
End Try
End If
'cover to Values
Dim x As Int32
Dim tot As Int32 = 0
For x = 0 To s.Length - 1 Step 1
Dim Val As Integer = ConvertToVal(s(x))
tot += Val
Next
Return CalcStupidNumber(tot.ToString())
End Function
Private Function ConvertToVal(ByVal c As Char) As Integer
If (Char.IsDigit(c)) Then
Return Integer.Parse(c)
End If
Return System.Convert.ToInt32(c) - 96 ' offest of a
End Function