How to integrate Replace in this Private Sub?
I need to replace all words "NONE" with "":
Private Sub UpdateSKU()
Dim str As String
str = Me.Combo216.Column(1) & Space(1) & Me.Combo224.Column(1) & Space(1)
Me.Text423.Value = str
End Sub
I have tried
Private Function NONE(a As String)
If InStr(a, "NONE") > 0 Then
MsgBox "Original: " & a & vbCrLf & "Adjusted: " & Replace(a, "NONE", "")
End If
End Function
But I can't get it to work.
A function should return a value...
Your function does not declare a return type, nor does it ever assign a return value.
Try this instead:
Private Function NONE(a As String) As String
NONE = Replace(a, "NONE", "")
End Function
Try this:
Private Sub UpdateSKU()
Dim Text As String
Text = Me.Combo216.Column(1) & Space(1) & Me.Combo224.Column(1) & Space(1)
Me.Text423.Value = Replace(Text, "NONE", "")
End Sub
Also, don't use common function names (Str) for variables, and do rename your controls to something meaningful.
So I get this error when trying to run my code "System.IndexOutOfRangeException: 'Index was outside the bounds of the array.'" I am not exactly sure what the issue is. The user should be able to enter 3 assignment grades and then see the averages
I marked the line where I get the error with 'THIS IS THE ERROR'
Public Class GradeBook
Dim grade(9, 2) As Integer 'Store 10 student grades on 3 tests'
Dim studentCount As Integer = 0 'Number of students entered'
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
GradeListBox.Items.Add(vbTab & vbTab & "Test 1" & vbTab & "Test 2" & vbTab & "Test 3" & vbTab & "Average")
End Sub
Private Sub SubmitButton_Click(sender As Object, e As EventArgs) Handles SubmitButton.Click
grade(studentCount, 0) = Convert.ToInt32(Assignment1TextBox.Text)
grade(studentCount, 1) = Convert.ToInt32(Assignment2TextBox.Text)
grade(studentCount, 2) = Convert.ToInt32(Assignment3TextBox.Text)
Dim output As String = "Student " & studentCount & vbTab
For column = 0 To grade.GetUpperBound(1)
If LetterRadioButton.Checked = True Then
output &= vbTab & LetterGrade(grade(studentCount, column))
Else
output &= vbTab & grade(studentCount, column)
End If
Next
output &= vbTab & CalculateStudentAverage(studentCount)
GradeListBox.Items.Add(output)
studentCount += 1
AverageLabel.Text = CalculateClassAverage()
displayBarChart()
End Sub
Function LetterGrade(ByVal grade As Double) As String
Dim output As String = ""
Select Case grade
Case Is >= 90
output = "A"
Case Is >= 80
output = "B"
Case Is >= 70
output = "C"
Case Is >= 60
output = "D"
Case Is >= 50
output = "E"
End Select
Return output
End Function
Function CalculateStudentAverage(ByVal row As Integer) As String
Dim gradeTotal As Integer = 0
For column = 0 To grade.GetUpperBound(1)
gradeTotal += grade(row, column) 'THIS IS THE ERROR'
Next
Dim studentAverage As String = String.Empty
If LetterRadioButton.Checked = True Then
studentAverage = LetterGrade(gradeTotal / (grade.GetUpperBound(1) + 1))
Else
studentAverage = String.Format("{0:F}", (gradeTotal / grade.GetUpperBound(1) + 1))
End If
Return studentAverage
End Function
Function CalculateClassAverage() As String
Dim classTotal As Integer = 0
For row = 0 To studentCount - 1
For column = 0 To grade.GetUpperBound(1)
classTotal += grade(row, column)
Next
Next
Dim classAverage As String = String.Empty
If LetterRadioButton.Checked = True Then
classAverage = LetterGrade(classTotal / (studentCount * (grade.GetUpperBound(1) + 1)))
Else
classAverage = String.Format("{0:F}", (classTotal / (studentCount * (grade.GetUpperBound(1) + 1))))
End If
Return classAverage
End Function
Sub displayBarChart()
GradeListBox.Items.Clear()
GradeListBox.Items.Add(vbTab & vbTab & "Test 1" & vbTab & "Test 2" & vbTab & "Test 3" & vbTab & "Average")
For row = 0 To studentCount - 1
Dim output As String = "Student " & row & vbTab
For column = 0 To grade.GetUpperBound(1)
If LetterRadioButton.Checked = True Then
output &= vbTab & LetterGrade(grade(row, column))
Else
output &= vbTab & (grade(row, column))
End If
Next
output &= vbTab & CalculateStudentAverage(studentCount)
GradeListBox.Items.Add(output)
studentCount += 1
AverageLabel.Text = CalculateClassAverage()
displayBarChart()
Assignment1TextBox.Clear()
Assignment2TextBox.Clear()
Assignment3TextBox.Clear()
If studentCount = grade.GetUpperBound(0) + 1 Then
InputGradeGroupBox.Enabled = False
End If
Next
End Sub
End Class
To be honest, I suspect you're going about it in a way not suited to OOP. Using arrays for multiple peices of data is prone to error and harder to maintain later.
Lets have a think about how you want to represent your data. You have a bunch of students. In a more complete example each student would have a name, personal details such as address, a list of the courses they're taking and for each course, a list of assignments and scores for each assignment which can also be represented as a grade.
So in essence you have a class called Student and the various bits of information are properties of that student.
Finally you have a list of these students
In your code, you simply have a student number and three assignment scores.
Your basic student class should have the properties of Number, Test1Score, Test2Score and Test3Score. You would also want to be able to get the grade from each score, the average of all the scores and the average of all the grades.
The code below defines the Student class with that information in mind
Friend Class Student
Public Property Number As Integer
Public Property Test1Score As Integer
Public Property Test2Score As Integer
Public Property Test3Score As Integer
Public Function Test1Grade() As String
Return LetterGrade(Test1Score)
End Function
Public Function Test2Grade() As String
Return LetterGrade(Test2Score)
End Function
Public Function Test3Grade() As String
Return LetterGrade(Test3Score)
End Function
Friend Shared Function LetterGrade(ByVal grade As Double) As String
Dim output As String = ""
Select Case grade
Case Is >= 90
output = "A"
Case Is >= 80
output = "B"
Case Is >= 70
output = "C"
Case Is >= 60
output = "D"
Case Is >= 50
output = "E"
Case Else
output = "F"
End Select
Return output
End Function
Friend Function AverageScore() As Double
Return (Test1Score + Test2Score + Test3Score) / 3
End Function
Friend Function AverageGrade() As String
Dim avgscore As Double = AverageScore()
Return LetterGrade(avgscore)
End Function
End Class
The function LetterGrade is Shared so that it can be used in your main form to calculate the average grade for the entire class.
OK Next think about how you want your program to work. You'll need a list of students, so at the beginning of your form class , you'll need this..
Public Class Form1
Private Students As New List(Of Student)
This way, instead of trying to keep track of your variable studentCount you can just use the .Count property of the List e.g Students.Count. You wont need to any adding to it as the Students list keeps track of it automatically.
Next, you'll want the function that calculates the average score/grade of the class..
Function CalculateClassAverage() As String
Dim classTotal As Integer = 0
For Each tmpStudent As Student In Students
With tmpStudent
classTotal += .Test1Score + .Test2Score + .Test3Score
End With
Next
Dim classAverage As String = String.Empty
If LetterRadioButton.Checked = True Then
classAverage = Student.LetterGrade((classTotal / Students.Count) / 3)
Else
classAverage = String.Format("{0:F}", (classTotal / (Students.Count)) / 3)
End If
Return classAverage
End Function
As you can see, there are a number of differences here because of the way your data is stored, but you should be able to follow it. One difference is the With statement, this allows you to save on typing. inside the With.. End With block, instead of typing tmpstudent.Test1Score etc, you can just type .Test1Score
The other thing of note is this line ..
classAverage = Student.LetterGrade( ... etc
You may think that there has been no declaration of a variable called Student. There IS a class, but not a variable. What this is actually doing is calling the LetterGrade function that is shared in the Student class definition.. Have a look at shared functions.
Next is the code to display the information in the ListBox. I haven't changed the name even though it is misleading btw.
Sub displayBarChart()
GradeListBox.Items.Clear()
GradeListBox.Items.Add(vbTab & vbTab & "Test 1" & vbTab & "Test 2" & vbTab & "Test 3" & vbTab & "Average")
For Each tmpstudent As Student In Students
Dim output As String = "Student " & tmpstudent.Number & vbTab
With tmpstudent
If LetterRadioButton.Checked = True Then
output &= .Test1Grade & vbTab & .Test2Grade & vbTab & .Test3Grade & vbTab & .AverageGrade
Else
output &= .Test1Score & vbTab & .Test2Score & vbTab & .Test3Score & vbTab & .AverageScore
End If
End With
GradeListBox.Items.Add(output)
AverageLabel.Text = CalculateClassAverage()
Next
If Students.Count = 10 Then
InputGradeGroupBox.Enabled = False
End If
End Sub
More use of the With..End With statements again, but the rest should be straighforward to follow.
A little extra bit of code.. When you click on the LetterRadioButton, the data in the listBox and ClassAveragelabel are refreshed with the appropriate letters/grades
Private Sub LetterRadioButton_CheckedChanged(sender As Object, e As EventArgs) Handles LetterRadioButton.CheckedChanged
AverageLabel.Text = CalculateClassAverage()
displayBarChart()
End Sub
Finally, to bring it all together, you have the code for the button click..
Private Sub SubmitButton_Click(sender As Object, e As EventArgs) Handles SubmitButton.Click
Dim tmpStudent As New Student With {.Number = Students.Count + 1,
.Test1Score = Convert.ToDouble(Assignment1TextBox.Text),
.Test2Score = Convert.ToDouble(Assignment2TextBox.Text),
.Test3Score = Convert.ToDouble(Assignment3TextBox.Text)}
Dim output As String = "Student " & tmpStudent.Number & vbTab
With tmpStudent
If LetterRadioButton.Checked = True Then
output &= vbTab & .Test1Grade & vbTab & .Test2Grade & vbTab & .Test3Grade
Else
output &= vbTab & .Test1Score & vbTab & .Test2Score & vbTab & .Test3Score
End If
End With
Students.Add(tmpStudent)
If LetterRadioButton.Checked Then
output &= vbTab & tmpStudent.AverageGrade
Else
output &= vbTab & tmpStudent.AverageScore
End If
GradeListBox.Items.Add(output)
AverageLabel.Text = CalculateClassAverage()
displayBarChart()
Assignment1TextBox.Clear()
Assignment2TextBox.Clear()
Assignment3TextBox.Clear()
End Sub
Hopefully in addition to my comment to your question, this provides a slightly better insight of OOP.
I create XML file from excel file. I save a string from one cell in a variable sObserved. When in that string I have a character "&" it should be replaced to "&"and when I have a character ";" it should be replaced to ";".
I use for this function Replace, this is my code:
sObserved = Replace(sObserved, "&", "&")
sObserved = Replace(sObserved, ";", ";")
But this can't work good, because when it will replace "&" on "&", the ";" will appear and next operation will change it to "&"
If I'll change an order it also will be wrong, because then sign "&" in ";" will be replaced.
Is there any possibility to replace it just like I wanted? I will be gratefull for any ideas because I stuck here.
Try this:
sObserved = Replace(sObserved, "&", "&")
sObserved = Replace(sObserved, ";", ";")
sObserved = Replace(sObserved, "&", "&")
This function is from http://www.codeproject.com/Articles/33064/VBScript-HTML-Encode. You may need to tweek it but it does a character by character check.
Function HTMLEncode(ByVal sVal)
sReturn = ""
If ((TypeName(sVal)="String") And (Not IsNull(sVal)) And (sVal<>"")) Then
For i = 1 To Len(sVal)
ch = Mid(sVal, i, 1)
Set oRE = New RegExp : oRE.Pattern = "[ a-zA-Z0-9]"
If (Not oRE.Test(ch)) Then
ch = "&#" & Asc(ch) & ";"
End If
sReturn = sReturn & ch
Set oRE = Nothing
Next
End If
HTMLEncode = sReturn
End Function
What you're after is a function to encode the output to be HTML friendly: htmlEncode. There are several scripts/functions around the web people have wrote, here is one:
' Encode an string so that it can be displayed correctly
' inside the browser.
'
' Same effect as the Server.HTMLEncode method in ASP
Function HTMLEncode(ByVal Text As String) As String
Dim i As Integer
Dim acode As Integer
Dim repl As String
HTMLEncode = Text
For i = Len(HTMLEncode) To 1 Step -1
acode = Asc(Mid$(HTMLEncode, i, 1))
Select Case acode
Case 32
repl = " "
Case 34
repl = """
Case 38
repl = "&"
Case 60
repl = "<"
Case 62
repl = ">"
Case 32 To 127
' don't touch alphanumeric chars
Case Else
repl = "&#" & CStr(acode) & ";"
End Select
If Len(repl) Then
HTMLEncode = Left$(HTMLEncode, i - 1) & repl & Mid$(HTMLEncode, _
i + 1)
repl = ""
End If
Next
End Function
ref: http://www.devx.com/vb2themax/Tip/19162
There is another here: http://www.codeproject.com/Articles/33064/VBScript-HTML-Encode
but that seems to encode everything that's not a character or letter. The regex in this one could probably be expanded a little better to include those that are ok for HTML.
Function HTMLEncode(ByVal sVal)
sReturn = ""
If ((TypeName(sVal)="String") And (Not IsNull(sVal)) And (sVal<>"")) Then
For i = 1 To Len(sVal)
ch = Mid(sVal, i, 1)
Set oRE = New RegExp : oRE.Pattern = "[ a-zA-Z0-9]"
If (Not oRE.Test(ch)) Then
ch = "&#" & Asc(ch) & ";"
End If
sReturn = sReturn & ch
Set oRE = Nothing
Next
End If
HTMLEncode = sReturn
End Function
Having some issues in vb.net string to join two strings together for output to a txt document. My text document is getting an extra space between the two strings I join. This should not be happening.
If System.IO.File.Exists(path) = True Then
' Create a file to write to.
Dim sw As StreamWriter = System.IO.File.CreateText(path)
sw.WriteLine("Attribute VB_Name = " & Chr(34) & "KbTest" & Chr(34))
sw.WriteLine("")
sw.WriteLine("Public Sub DoKbTest()")
sw.WriteLine("'code here")
sw.WriteLine("Dim catia")
sw.WriteLine("set catia = GetObject(, " & Chr(34) & "CATIA.Application" & Chr(34) & ")")
sw.WriteLine("Dim partDocument1")
sw.WriteLine("Set partDocument1 = catia.ActiveDocument")
sw.WriteLine("Dim part1")
sw.WriteLine("Set part1 = partDocument1.Part")
sw.WriteLine("Dim hybridShapeFactory1")
sw.WriteLine("Set hybridShapeFactory1 = part1.HybridShapeFactory")
sw.WriteLine("Dim hybridShapeDirection1")
sw.WriteLine("Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirectionByCoord(1#, 2#, 3#)")
sw.WriteLine("Dim hybridBodies1")
sw.WriteLine("Set hybridBodies1 = part1.HybridBodies")
sw.WriteLine("Dim hybridBody1")
sw.WriteLine("Set hybridBody1 = hybridBodies1.Item(" & Chr(34) & "PointSetx" & Chr(34) & ")")
sw.WriteLine("dim skteches1")
sw.WriteLine("Set sketches1 = hybridBody1.HybridSketches")
sw.WriteLine("Dim sketch1")
sw.WriteLine("Set sketch1 = sketches1.Item(" & Chr(34) & "Sketch.1" & Chr(34) & ")")
sw.WriteLine("Dim reference1")
sw.WriteLine("Set reference1 = part1.CreateReferenceFromObject(sketch1)")
sw.WriteLine("Dim hybridShapeExtremum1")
sw.WriteLine("Set hybridShapeExtremum1 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeDirection1, 1)")
sw.WriteLine("hybridBody1.AppendHybridShape hybridShapeExtremum1")
sw.WriteLine("Dim reference2")
Dim lessOneCount As String
Dim spacing As Double = 0
Dim count As String
Dim setString As String
'loop
THIS IS THE PART OF THE CODE THAT IS ADDING EXTRA SPACES
For i = 1 To numbOfPoints Step 1
count = Str(i)
count.Replace(" ", "")
MsgBox(count)
If i < 2 Then
lessOneCount = "hybridShapeExtremum1"
Else
lessOneCount = "HybridShapePointOnCurve" + Str(i - 1)
End If
sw.WriteLine("reference2 = part1.CreateReferenceFromObject(" + lessOneCount + ")")
setString = "Dim hybridShapePointOnCurve" + count
sw.WriteLine(setString)
setString = "hybridShapePointOnCurve" + count + " = hybridShapeFactory1.AddNewPointOnCurveWithReferenceFromDistance(reference1, reference2, spacing, False)"
sw.WriteLine(setString)
setString = "hybridShapePointOnCurve" + count + ".DistanceType = 1"
sw.WriteLine(setString)
setString = "hybridBody1.AppendHybridShape(hybridShapePointOnCurve" + count + ")"
sw.WriteLine(setString)
Next
sw.WriteLine("End Sub")
sw.Flush()
sw.Close()
End If
Sample output:
Dim hybridShapePointOnCurve 2
SHOULD be:
Dim hybridShapePointOnCurve2
What modifications should I make to the way I join strings?
Thanks!
Realized my comment didn't answer your question completely, so a few things:
The String.Replace method doesn't work like you think it does. Saying count.Replace(" ", "") doesn't actually change the variable count; the function actually returns a new string. For it work like you want, you would need to do count = count.Replace(" ", "").
Consider using a StringBuilder instead of concatenating a bunch of strings together. It will greatly improve performance. When using the StringBuilder class, you also wouldn't need to write to the StreamWriter until the very end, simply by calling sw.Write(stringBuilderObject.ToString())
I haven't used VB.NET in a while, but I would check what Str(i) returns. Instead of using VB functions, consider using .NET functions by saying count = i.ToString(). According to Sky, the Str function indeed returns a space because it reserves it for the negative sign. Based on this, I would use the .ToString() method instead.
I spoke to quickly in my comment, the Str function reserves room for the sign, since it is a positive number there is no sign, if it was negative there would be a minus sign there. Try Trim(Str(i)) instead
From above link(emphasis mine):
This example uses the Str function to return a String representation of a number. When a positive number is converted to a string, a leading space is always reserved for its sign.
I have an excel file with one order on each row, and I want each order to have a unique identifier, so there will be a Unique ID column. Every time I fill a row, I want Excel to automatically populate the Unique ID column for me. I did some research and was pointed in the direction of GUIDs. I found the following code:
Function GenGuid() As String
Dim TypeLib As Object
Dim Guid As String
Set TypeLib = CreateObject("Scriptlet.TypeLib")
Guid = TypeLib.Guid
' format is {24DD18D4-C902-497F-A64B-28B2FA741661}
Guid = Replace(Guid, "{", "")
Guid = Replace(Guid, "}", "")
Guid = Replace(Guid, "-", "")
GenGuid = Guid
End Function
but I am not sure how I can implement it. Any help would be greatly appreciated. Thank you in advance.
The following Excel expression evaluates to a V4 GUID:
=CONCATENATE(DEC2HEX(RANDBETWEEN(0,4294967295),8),"-",DEC2HEX(RANDBETWEEN(0,65535),4),"-",DEC2HEX(RANDBETWEEN(16384,20479),4),"-",DEC2HEX(RANDBETWEEN(32768,49151),4),"-",DEC2HEX(RANDBETWEEN(0,65535),4),DEC2HEX(RANDBETWEEN(0,4294967295),8))
-or (depending on locale setting/decimal and list separators)-
=CONCATENATE(DEC2HEX(RANDBETWEEN(0;4294967295);8);"-";DEC2HEX(RANDBETWEEN(0;65535);4);"-";DEC2HEX(RANDBETWEEN(16384;20479);4);"-";DEC2HEX(RANDBETWEEN(32768;49151);4);"-";DEC2HEX(RANDBETWEEN(0;65535);4);DEC2HEX(RANDBETWEEN(0;4294967295);8))
Note that the first character of the third group is always 4 to signify a V4 (pseudo-random number generated) GUID/UUID per RFC 4122 section 4.4.
Also note that the first character of the fourth group is always between 8 and B per the same RFC.
Standard disclaimer: the resulting GUIDs/UUIDs are not cryptographically strong.
Edit: remove invisible characters
I used the following function in v.2013 excel vba to create a GUID and is working well..
Public Function GetGUID() As String
GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
I know this question is answered, but I think the code in question should look something like what's on this page: http://snipplr.com/view/37940/
Haven't tested, but this code seems to tap into the Windows API to get its GUID's - I would try putting that in a public module and typing =GetGUId() in an Excel cell to see what I'd get. If it works in VB6 you have a great deal of a good chance it works in VBA as well:
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
Public Function GetGUID() As String
'(c) 2000 Gus Molina
Dim udtGUID As GUID
If (CoCreateGuid(udtGUID) = 0) Then
GetGUID = _
String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
End If
End Function
Thanks Gus Molina!
If this code works (which I don't doubt), I think you'd get a new set of GUID's whenever the function gets evaluated, which means everytime the sheet gets calculated - when you're saving the workbook, for example. Make sure to copy-pastespecial-values if you need the GUID's for later use... which is somewhat likely.
A VBA approach based on generating random numbers using the Rnd() function, and not on external API calls or Scriptlet.TypeLib:
Public Function CreateGUID() As String
Do While Len(CreateGUID) < 32
If Len(CreateGUID) = 16 Then
'17th character holds version information
CreateGUID = CreateGUID & Hex$(8 + CInt(Rnd * 3))
End If
CreateGUID = CreateGUID & Hex$(CInt(Rnd * 15))
Loop
CreateGUID = "{" & Mid(CreateGUID, 1, 8) & "-" & Mid(CreateGUID, 9, 4) & "-" & Mid(CreateGUID, 13, 4) & "-" & Mid(CreateGUID, 17, 4) & "-" & Mid(CreateGUID, 21, 12) & "}"
End Function
This essentially is a VBA implementation of NekojiruSou's answer (it also generates a v4 GUID), and carries the same limitations, but will work in VBA and might be easier to implement.
Note that you can omit the last line to not return the dashes and curly braces in the result.
I found pretty solution here:http://www.sql.ru/forum/actualutils.aspx?action=gotomsg&tid=751237&msg=8634441
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function CoCreateGuid Lib "ole32" (pguid As GUID) As Long
Private Declare Function StringFromGUID2 Lib "ole32" ( _
rguid As GUID, ByVal lpsz As Long, ByVal cchMax As Long) As Long
Public Function CreateGUID() As String
Dim NewGUID As GUID
CoCreateGuid NewGUID
CreateGUID = Space$(38)
StringFromGUID2 NewGUID, StrPtr(CreateGUID), 39
End Function
This is based on a javascript implementation.
Private Function getGUID() As String
Call Randomize 'Ensure random GUID generated
getGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx"
getGUID = Replace(getGUID, "y", Hex(Rnd() And &H3 Or &H8))
Dim i As Long: For i = 1 To 30
getGUID = Replace(getGUID, "x", Hex$(Int(Rnd() * 16)), 1, 1)
Next
End Function
Same same for german Excel version:
=VERKETTEN(DEZINHEX(ZUFALLSBEREICH(0;4294967295);8);"-";DEZINHEX(ZUFALLSBEREICH(0;65535);4);"-";DEZINHEX(ZUFALLSBEREICH(16384;20479);4);"-";DEZINHEX(ZUFALLSBEREICH(32768;49151);4);"-";DEZINHEX(ZUFALLSBEREICH(0;65535);4);DEZINHEX(ZUFALLSBEREICH(0;4294967295);8))
Since windows update taken out "Scriptlet.TypeLib", try the following:
Declare Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As Long
Public Function GenerateGUID() As String
Dim ID(0 To 15) As Byte
Dim N As Long
Dim GUID As String
Dim Res As Long
Res = CoCreateGuid(ID(0))
For N = 0 To 15
GUID = GUID & IIf(ID(N) < 16, "0", "") & Hex$(ID(N))
If Len(GUID) = 8 Or Len(GUID) = 13 Or Len(GUID) = 18 Or Len(GUID) = 23 Then
GUID = GUID & "-"
End If
Next N
GenerateGUID = GUID
End Function
Alternatively,
if you are connecting to SQL Server 2008 or higher, try to use the SQL NEWID() function instead.
I created a VBA function that works both on mac and windows:
https://github.com/Martin-Carlsson/Business-Intelligence-Goodies/blob/master/Excel/GenerateGiud/GenerateGiud.bas
'Generates a guid, works on both mac and windows
Function Guid() As String
Guid = RandomHex(3) + "-" + _
RandomHex(2) + "-" + _
RandomHex(2) + "-" + _
RandomHex(2) + "-" + _
RandomHex(6)
End Function
'From: https://www.mrexcel.com/forum/excel-questions/301472-need-help-generate-hexadecimal-codes-randomly.html#post1479527
Private Function RandomHex(lngCharLength As Long)
Dim i As Long
Randomize
For i = 1 To lngCharLength
RandomHex = RandomHex & Right$("0" & Hex(Rnd() * 256), 2)
Next
End Function
I recently ran into problems using CreateObject("Scriptlet.TypeLib") in some vba code.
So based on NekojiruSou excel functions wrote the following which should work without any specific excel functions. This can be used to develop a user defined function in excel.
Public Function Get_NewGUID() As String
'Returns GUID as string 36 characters long
Randomize
Dim r1a As Long
Dim r1b As Long
Dim r2 As Long
Dim r3 As Long
Dim r4 As Long
Dim r5a As Long
Dim r5b As Long
Dim r5c As Long
'randomValue = CInt(Math.Floor((upperbound - lowerbound + 1) * Rnd())) + lowerbound
r1a = RandomBetween(0, 65535)
r1b = RandomBetween(0, 65535)
r2 = RandomBetween(0, 65535)
r3 = RandomBetween(16384, 20479)
r4 = RandomBetween(32768, 49151)
r5a = RandomBetween(0, 65535)
r5b = RandomBetween(0, 65535)
r5c = RandomBetween(0, 65535)
Get_NewGUID = (PadHex(r1a, 4) & PadHex(r1b, 4) & "-" & PadHex(r2, 4) & "-" & PadHex(r3, 4) & "-" & PadHex(r4, 4) & "-" & PadHex(r5a, 4) & PadHex(r5b, 4) & PadHex(r5c, 4))
End Function
Public Function Floor(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double
'From: http://www.tek-tips.com/faqs.cfm?fid=5031
' X is the value you want to round
' Factor is the multiple to which you want to round
Floor = Int(X / Factor) * Factor
End Function
Public Function RandomBetween(ByVal StartRange As Long, ByVal EndRange As Long) As Long
'Based on https://msdn.microsoft.com/en-us/library/f7s023d2(v=vs.90).aspx
' randomValue = CInt(Math.Floor((upperbound - lowerbound + 1) * Rnd())) + lowerbound
RandomBetween = CLng(Floor((EndRange - StartRange + 1) * Rnd())) + StartRange
End Function
Public Function PadLeft(text As Variant, totalLength As Integer, padCharacter As String) As String
'Based on https://stackoverflow.com/questions/12060347/any-method-equivalent-to-padleft-padright
' with a little more checking of inputs
Dim s As String
Dim inputLength As Integer
s = CStr(text)
inputLength = Len(s)
If padCharacter = "" Then
padCharacter = " "
ElseIf Len(padCharacter) > 1 Then
padCharacter = Left(padCharacter, 1)
End If
If inputLength < totalLength Then
PadLeft = String(totalLength - inputLength, padCharacter) & s
Else
PadLeft = s
End If
End Function
Public Function PadHex(number As Long, length As Integer) As String
PadHex = PadLeft(Hex(number), 4, "0")
End Function
For generating random guids using just the Rnd() function, not using any libraries or APIs, the simplest I can think of is this:
' UUID Version 4 (random)
Function GetUUID4()
Dim guid As String
Dim i As Integer
Dim r As Integer
guid = ""
Randomize
For i = 0 To 31
' random digit 0..15
r = Rnd() * 15
' add dash separators
If (i = 8) Or (i = 12) Or (i = 16) Or (i = 20) Then guid = guid & "-"
' uuid4 version info in 12th and 16th digits
If (i = 12) Then r = 4
If (i = 16) Then r = (r And 3 Or 8)
' add as hex digit
guid = guid & Hex(r)
Next i
GetUUID4 = guid
End Function
If you are inserting records into a database you can use this way to make a GUID.
It is probably the most simplest and easiest way to implement as you don't need a complex VBA function as you use the built in SQL function.
The statement uses NewID(),
The syntax is as follows,
INSERT INTO table_name (ID,Column1,Column2,Column3)
VALUES (NewID(),value1,value2,value3)
In VBA syntax it is as follows,
strSql = "INSERT INTO table_name " _
& "(ID,Column1,Column2,Column3) " _
& "VALUES (NewID(),value1,value2,value3)"
And if you need to concatenate values, just treat it as a string and concatenate as you would normally for a SQL statement,
strSql = "INSERT INTO table_name " _
& "(ID,Column1,Column2,Column3) " _
& "VALUES (" & "NewID()" & "," & "value1" & "," & "value2" & "," & "value3" & ")"
Function funGetGuid() As String
Const URL As String = "http://www.guidgen.com/"
Const strMask As String = "value="
Dim l As Long
Dim txt As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
txt = .responseText
End With
Do
l = InStr(l + 1, txt, strMask)
If l = 0 Then Exit Do
funGetGuid = Mid$(txt, l + Len(strMask) + 1, 36)
Loop
End Function