Multiple Vlookup Result - excel

i am trying to get multiple vlookup in single cell
I am getting #VALUE! error with the below function, Need help to correct the code
MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)
Dim i As Long
Dim Result As String
For i = 1 To LookupRange.Columns(1).Cells.Count
If LookupRange.Cells(i, 1) = Lookupvalue Then
For J = 1 To i - 1
If LookupRange.Cells(J, 1) = Lookupvalue Then
If LookupRange.Cells(J, ColumnNumber) = LookupRange.Cells(i, ColumnNumber) Then
GoTo Skip
End If
End If
Next J
Result = Result & " " & LookupRange.Cells(i, ColumnNumber) & ","
Skip:
End If
Next i
MultipleLookupNoRept = Left(Result, Len(Result) - 1)
End Function

This code works for me. Most of it is the original code.
Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) As String
Dim i As Long
Dim Result As String
For i = 1 To LookupRange.Columns(1).Cells.Count
If LookupRange.Cells(i, 1) = Lookupvalue Then
Result = Result & " " & LookupRange.Cells(i, ColumnNumber) & ","
End If
Next i
If (Len(Result) = 0) Then
MultipleLookupNoRept = 0
Else
MultipleLookupNoRept = Left(Result, Len(Result) - 1)
End If
End Function

'This code should help
' Syntax =MVLOOKUP(Lookup_value,Table_array,Col_index_number)
Option Explicit
Function mvlookup(lookupValue, tableArray As Range, colIndexNum As Long, _
Optional NotUsed As Variant) As Variant
Dim initTable As Range
Dim myRowMatch As Variant
Dim myRes() As Variant
Dim myStr As String
Dim initTableCols As Long
Dim i As Long
Dim ubound_myRes As Long
Set initTable = Nothing
On Error Resume Next
Set initTable = Intersect(tableArray, _
tableArray.Parent.UsedRange.EntireRow)
On Error GoTo 0
If initTable Is Nothing Then
mvlookup = CVErr(xlErrRef)
Exit Function
End If
initTableCols = initTable.Columns.Count
i = 0
Do
myRowMatch = Application.Match(lookupValue, initTable.Columns(1), 0)
If IsError(myRowMatch) Then
Exit Do
Else
i = i + 1
ReDim Preserve myRes(1 To i)
myRes(i) _
= initTable(1).Offset(myRowMatch - 1, colIndexNum - 1).Text
If initTable.Rows.Count <= myRowMatch Then
Exit Do
End If
On Error Resume Next
Set initTable = initTable.Offset(myRowMatch, 0) _
.Resize(initTable.Rows.Count - myRowMatch, _
initTableCols)
On Error GoTo 0
If initTable Is Nothing Then
Exit Do
End If
End If
Loop
If i = 0 Then
mvlookup = CVErr(xlErrNA)
Exit Function
End If
myStr = ""
For i = LBound(myRes) To UBound(myRes)
myStr = myStr & ", " & myRes(i)
Next i
mvlookup = Mid(myStr, 3)
End Function

Related

VBA code to return multiple lookup values in one comma separated works but crashes if there's an empty cell

I've found this code online which works like vlookup function but returns multiple data in one cell separated by comma and it works most of the time. But when there's a blank cell in the lookup value it causes a crash. It takes a long time to process too.
I tried to tinker with it but I'm completely new to VBA coding. I was wondering if anyone could please help me fix the issue and maybe optimize the code a little so it doesn't crash or take as long.
Lookup value
Table array
Here's the code
Function MultiVLookUp(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, Char As String)
Dim I As Long
Dim xRet As String
For I = 1 To LookupRange.Columns(1).Cells.Count
If LookupRange.Cells(I, 1) = LookupValue Then
If xRet = "" Then
xRet = LookupRange.Cells(I, ColumnNumber) & Char
Else
xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
End If
End If
Next
MultiVLookUp = Left(xRet, Len(xRet) - 1)
End Function
Thanks in advance.
Multi VLookUp: Delimited Return (UDF)
You'll use it in the same way as before, only I set the last parameter, the parameter of the Char (Delimiter) argument, as optional (default) to your 'favorite' ", " so you don't need to add it anymore.
If you were using an array formula, don't do it anymore.
Option Explicit
Function MultiVLookUp( _
ByVal LookupValue As String, _
ByVal LookupRange As Range, _
ByVal ColumnNumber As Long, _
Optional ByVal Char As String = ", ") _
As String
If Len(LookupValue) = 0 Then Exit Function
Dim lData As Variant
Dim vData As Variant
Dim lrCount As Long
With LookupRange
lrCount = .Rows.Count
If lrCount = 1 Then
ReDim lData(1 To 1, 1 To 1): lData(1, 1) = .Columns(1).Value
ReDim vData(1 To 1, 1 To 1): vData(1, 1) _
= .Columns(ColumnNumber).Value
Else
lData = .Columns(1).Value
vData = .Columns(ColumnNumber).Value
End If
End With
Dim r As Long
Dim rString As String
For r = 1 To lrCount
If CStr(lData(r, 1)) = LookupValue Then
rString = rString & CStr(vData(r, 1)) & Char
End If
Next r
If Len(rString) = 0 Then Exit Function
MultiVLookUp = Left(rString, Len(rString) - Len(Char))
End Function
Im not really sure the point of this macro considering it just outputs the same value repeatedly but here ya go.
Sub main()
' ws is the worksheet object referencing "Sheet1"
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
' Top Left (r, c) (r, c) Bottom Right
Dim rng As Range: Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(6, 6))
Dim lookupValue As String: lookupValue = ""
Dim outStr As String: outStr = rangeValuesToString(rng, lookupValue)
Debug.Print outStr
End Sub
Function rangeValuesToString(rng As Range, lookupValue As String) As String
Dim topRow As Integer: topRow = rng.Row
Dim botRow As Integer: botRow = rng.Row - 1 + rng.Rows.Count
Dim leftCol As Integer: leftCol = rng.Column
Dim rightCol As Integer: rightCol = rng.Column - 1 + rng.Columns.Count
Dim i As Integer, j As Integer
Dim outStr As String: outStr = ""
' Iterates through each column moving left to right
For i = leftCol To rightCol
For j = topRow To botRow
If rng.Cells(j, i).Value = lookupValue Then
outStr = outStr & rng.Cells(j, i).Value & ", "
End If
Next j
Next i
rangeValuesToString = Left(outStr, Len(outStr) - 2)
End Function

Grouping Worksheets with Similar Name Suffix

I'm struggeling to figure out the best way to attack this problem. I'm looking to group worksheet tabs and color code them based on the suffix.
Eg:
Worksheet Names:
ToDo_XY
Done_ZY
ToDo_ZY
Done_XY
Should be:
ToDo_XY
Done_XY
ToDo_ZY
Done_ZY
I know that the worksheet name will end in "non alphanumeric character" in the 3rd last position then two letters and I need to group by the two letters.
I'm not sure if I should be using a collection, or a dictionary or somehow arrays.
Here is what I have so far:
Public Sub GroupLabSheets()
Call GetLabListFromTextFile
Dim ThirdLastCharStr As String, ThirdLastCharStrIsAlphaNumBool As Boolean, PossibleLabStr As String, PossibleLabStrExistsBool As Boolean
For Each ws In ActiveWorkbook.Sheets
ThirdLastCharStr = Mid(ws.Name, Len(ws.Name) - 3, 1)
ThirdLastCharStrIsAlphaNumBool = IsAlphaNumeric(ThirdLastCharStr)
PossibleLabStr = Right(ws.Name, 2)
PossibleLabStrExistsBool = mylabs.Exists(PossibleLabStr)
If ThirdLastCharStrIsAlphaNumBool = False And PossibleLabStrExistsBool = True Then
Debug.Print "Worksheet Name = " & ws.Name & " - Index = " & ws.Index
End If
Next ws
Dim WSArr As Variant
WSArr = Array("ToDo_XY", "Done_XY")
'WSArr.Move Before:=Sheets(1)
Dim i As Long
For i = LBound(WSArr) To UBound(WSArr)
Debug.Print Worksheets(WSArr(i)).Name
Worksheets(WSArr(i)).Tab.Color = WHLabTabColor
Worksheets(WSArr(i)).Move Before:=Sheets(1)
Next i
End Sub
Public Function IsAlphaNumeric(ByVal vInput As Variant) As Boolean
On Error GoTo Error_Handler
Dim oRegEx As Object
If IsNull(vInput) = False Then
Set oRegEx = CreateObject("VBScript.RegExp")
oRegEx.Pattern = "^[a-zA-Z0-9]+$"
IsAlphaNumeric = oRegEx.Test(vInput)
Else
IsAlphaNumeric= True 'Null value returns True, modify as best suits your needs
End If
Error_Handler_Exit:
On Error Resume Next
If Not oRegEx Is Nothing Then Set oRegEx = Nothing
Exit Function
Error_Handler:
Debug.Print "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & err.Number & vbCrLf & _
"Error Source: IsAlphaNumeric" & vbCrLf & _
"Error Description: " & err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Try this:
Sub ArrangeSheets()
Dim i As Long, wb As Workbook, ws As Worksheet
Dim dict As Object, suffix, colors, col As Collection, n As Long
colors = Array(vbRed, vbYellow, vbGreen, vbBlue) 'colors to be applied (may need to add more...)
Set dict = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook
'collect and group all matched worksheets according to their suffix
For Each ws In wb.Worksheets
If SortIt(ws) Then
suffix = Right(ws.Name, 2)
If Not dict.exists(suffix) Then dict.Add suffix, New Collection
dict(suffix).Add ws
End If
Next ws
'now loop over the groups and move all sheets in a group
' after the first sheet in that group
For i = 0 To dict.Count - 1
Set col = dict.Items()(i)
For n = 1 To col.Count
Set ws = col(n)
ws.Tab.Color = colors(i)
If n > 1 Then ws.Move after:=col(n - 1)
Next n
Next i
End Sub
'is this worksheet a candidate for sorting?
Function SortIt(ws As Worksheet) As Boolean
Dim nm As String
nm = UCase(ws.Name)
If Len(nm) >= 4 Then
SortIt = (Not Mid(nm, Len(nm) - 2, 1) Like "[A-Z0-9]") And _
Right(nm, 2) Like "[A-Z][A-Z]"
End If
End Function
Try this code:
Option Explicit
Sub RearrangeTabs()
Dim a() As String, i As Integer, j As Integer, buf As String, ws As Worksheet
Dim colour As Long
With ActiveWorkbook
ReDim a(1 To .Worksheets.Count, 1 To 2)
i = 1
For Each ws In .Worksheets
buf = ws.Name
' make sort key
a(i, 1) = Right(buf, 2) & IIf(Left(buf, 1) = "T", "A", "Z")
a(i, 2) = buf
i = i + 1
Next
' primitive bubble sort
For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(a, 1) To UBound(a, 1)
If a(i, 1) < a(j, 1) Then
buf = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = buf
buf = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = buf
End If
Next j
Next i
colour = 3 'start ColorIndex (built-in set of colors [1..56])
For i = UBound(a, 1) To LBound(a, 1) Step -1
Set ws = .Worksheets(a(i, 2))
ws.Tab.ColorIndex = colour
ws.Move Before:=.Worksheets(1)
' increment ColorIndex for every odd i
If i Mod 2 = 1 Then colour = colour Mod 56 + 1
Next i
End With
End Sub
Before
After

Subscript out of range, does not enter the loop

Public Function APortfolioReturnsXL1(Returns As Range, Weights As Range) As Double()
On Error GoTo errHandler
Dim arrReturns() As Double
Dim arrWeights() As Double
Dim TotRows As Double
Dim TotCols As Double
Dim RowCtr As Double
Dim Colctr As Double
Dim WgtColctr As Double
Dim WgtRows As Double
TotRows = Returns.Rows.Count
TotCols = Returns.Columns.Count
WgtRows = Weights.Rows.Count
ReDim arrReturns(1 To TotRows, 1 To TotCols)
For RowCtr = 1 To TotRows
For Colctr = 1 To TotCols
arrReturns(RowCtr, Colctr) = Val(Returns.Cells(RowCtr, Colctr).Value)
Next
Next
ReDim arrWeights(1 To WgtRows, 1 To 1)
For WgtColctr = 1 To WgtRows
arrWeights(WgtColctr) = Val(Weights.Cells(WgtColctr, 1).Value)
Next
APortfolioReturnsXL1 = APortfolioReturns(arrReturns(), arrWeights())
Exit Function
errHandler:
MsgBox "An error has occurred." & vbCrLf & Err.Description & vbCrLf & CStr(Err.Number)
End Function
I am getting an
error subscript out of range
.
it doesnt enter the loop in the this line:
For WgtColctr = 1 To WgtRows
arrWeights(WgtColctr) = Val(Weights.Cells(WgtColctr, 1).Value)
Next
You are trying to assign value to a 2D array.
Use: arrWeights(WgtColctr, 1) = Val(Weights.Cells(WgtColctr, 1).Value)
Instead of: arrWeights(WgtColctr) = Val(Weights.Cells(WgtColctr, 1).Value)

VB - Import CSV in excel with end line in same cell

Ok, this gonna be long.
I have a csv file that I want to import in a excel.
This is the CSV file.
"NIP";"Date start";"Date end";"Reason";"coment"
"1";"06/06/17 09:55";"";"test";"asdasd ad ,a dasds asd;asdfasfasdfad ,
asdfasdfda a
asffasd , asdf asf asfad; asfasfasfa ;sadfdasds
,adasdsa ,asdassda,adadasddasd, asd asdasdad
;;;;adasdasdsa ,,,,sfdafas"
This is how looks on excel.
When this CSV is imported on excel using VB (the excel will import a lot of csv files), this is how it looks.
This is my VB code to import CSV
Option Explicit
Sub ImportFiles()
Dim sPath As String
sPath = ThisWorkbook.Path & "\data\1.csv"
'copyDataFromCsvFileToSheet sPath, ";", "1"
sPath = ThisWorkbook.Path & "\data\2.csv"
'copyDataFromCsvFileToSheet sPath, ";", "2"
sPath = ThisWorkbook.Path & "\data\3.csv"
'copyDataFromCsvFileToSheet sPath, ";", "3"
sPath = ThisWorkbook.Path & "\data\4.csv"
'copyDataFromCsvFileToSheet sPath, ";", "4"
sPath = ThisWorkbook.Path & "\data\5.csv"
'copyDataFromCsvFileToSheet sPath, ";", "5"
sPath = ThisWorkbook.Path & "\data\6.csv"
'copyDataFromCsvFileToSheet sPath, ";", "6"
sPath = ThisWorkbook.Path & "\data\7.csv"
'copyDataFromCsvFileToSheet sPath, ";", "7"
sPath = ThisWorkbook.Path & "\data\8.csv"
'copyDataFromCsvFileToSheet sPath, ";", "8"
sPath = ThisWorkbook.Path & "\data\9.csv"
'copyDataFromCsvFileToSheet sPath, ";", "9"
sPath = ThisWorkbook.Path & "\data\10.csv"
'copyDataFromCsvFileToSheet sPath, ";", "10"
sPath = ThisWorkbook.Path & "\data\11.csv"
'copyDataFromCsvFileToSheet sPath, ";", "11"
sPath = ThisWorkbook.Path & "\data\12.csv"
copyDataFromCsvFileToSheet sPath, ";", "12"
sPath = ThisWorkbook.Path & "\data\13.csv"
'copyDataFromCsvFileToSheet sPath, ";", "13"
Dim aux As String
aux = FindReplaceAll()
End Sub
Private Sub copyDataFromCsvFileToSheet(parFileName As String, _
parDelimiter As String, parSheetName As String)
Dim Data As Variant
Data = getDataFromFile(parFileName, parDelimiter)
If Not isArrayEmpty(Data) Then
If SheetExists(parSheetName) Then
With Sheets(parSheetName)
.Range("A1:OO2000").ClearContents
.Cells(1, 1).Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End With
Else
Dim warning
warning = MsgBox("no existing sheet'" & parSheetName, vbOKOnly, "Warning")
End If
End If
End Sub
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
Function FindReplaceAll()
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=Chr(34), Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
End Function
Public Function isArrayEmpty(parArray As Variant) As Boolean
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then
isArrayEmpty = True
Exit Function
Else
isArrayEmpty = False
End If
End Function
Private Function getDataFromFile(parFileName As String, _
parDelimiter As String, _
Optional parExcludeCharacter As String = "") As Variant
Dim locLinesList() As Variant
Dim locData As Variant
Dim i As Long
Dim j As Long
Dim lim As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
Dim aux As String
aux = ts.ReadLine
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList _
(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
lim = UBound(Split(aux, parDelimiter)) + 1
End If
locLinesList(i + 1) = Split(aux, """+parDelimiter+""")
j = UBound(locLinesList(i + 1), 1)
If locNumCols < j Then locNumCols = j
i = i + 1
Loop
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = _
Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2)
Else
locLinesList(i)(j) = _
Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = _
Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
Else
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
error_open_file:
unhandled_error:
End Function
I want that in the excel to look like when you open the csv in excel.
This was my solution.
First I added two new functions.
Public Function mergeArrays(arr1 As Variant, arr2 As Variant) As Variant
Dim i As Integer
Dim sizeArr1 As Integer
Dim arr3() As String
ReDim arr3(UBound(arr1) + UBound(arr2) + 1)
sizeArr1 = UBound(arr1) + 1
For i = 0 To UBound(arr1)
arr3(i) = arr1(i)
Next i
For i = 0 To UBound(arr2)
arr3(i + sizeArr1) = arr2(i)
Next i
mergeArrays = arr3
End Function
Public Function DeleteElementAt(inArray As Variant) As Variant
Dim index As Integer
Dim aux() As String
ReDim aux(UBound(inArray) - 1)
For index = 1 To UBound(inArray)
aux(index - 1) = inArray(index)
Next index
DeleteElementAt = aux
End Function
Also I modified getDataFromFile
Private Function getDataFromFile(parFileName As String, _
parDelimiter As String, _
Optional parExcludeCharacter As String = "") As Variant
Dim locLinesList() As Variant
Dim locData As Variant
Dim linea() As String
Dim i As Long
Dim j As Long
Dim lim As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
Dim aux As String
aux = ts.ReadLine
aux = Replace(aux, Chr(34) & ";" & Chr(34), Chr(34) & "###" & Chr(34))
linea = Split(aux, "###")
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList _
(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
lim = UBound(linea) + 1
locNumCols = lim
locLinesList(i + 1) = linea
i = i + 1
Else
locLinesList(i + 1) = linea
If UBound(locLinesList(i)) + 1 < lim Then
locLinesList(i)(UBound(locLinesList(i))) = locLinesList(i)
(UBound(locLinesList(i))) & vbCrLf & linea(0)
linea = DeleteElementAt(linea)
locLinesList(i) = mergeArrays(locLinesList(i), linea)
Else
If UBound(linea) + 1 = 1 Then
locLinesList(i)(UBound(locLinesList(i))) = locLinesList(i)
(UBound(locLinesList(i))) & vbCrLf & linea(0)
Else
'Linea es un salto de linea a secas
If UBound(linea) = -1 Then
locLinesList(i)(UBound(locLinesList(i))) = locLinesList(i)
(UBound(locLinesList(i))) & vbCrLf
Else
i = i + 1
End If
End If
End If
End If
Loop
Dim endVector() As Variant
ReDim endVector(i)
Dim index As Integer
For index = 0 To i - 1
endVector(index) = locLinesList(index + 1)
Next index
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function
ReDim locData(1 To locNumRows, 1 To locNumCols) As Variant
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(endVector(i), 1)
If Left(endVector(i)(j), 1) = parExcludeCharacter Then
If Right(endVector(i)(j), 1) = parExcludeCharacter Then
endVector(i)(j) = _
Mid(endVector(i)(j), 2, Len(endVector(i)(j)) - 2)
Else
endVector(i)(j) = _
Right(endVector(i)(j), Len(endVector(i)(j)) - 1)
End If
ElseIf Right(endVector(i)(j), 1) = parExcludeCharacter Then
endVector(i)(j) = _
Left(endVector(i)(j), Len(endVector(i)(j)) - 1)
End If
locData(i, j + 1) = endVector(i)(j)
Next j
Next i
Else
For i = 0 To locNumRows - 1
For j = 0 To UBound(endVector(i), 1)
locData(i + 1, j + 1) = endVector(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
I know that this code can optimized but for now It works

Excel VBA - Set values of Enumerated elements

In a Class Module there is:
Private Enum colType
ID = "A"
SSN = "B"
lName = "H"
fName = "G"
End Enum
as a private member. Whenever the class initializes I get the Compile Error: Type Mismatch message. If I declare colType as Private Enum coltype As String. That gets highlighted red as an error and I get the message:
Compile Error: Expected end of statement
Is specifying the values of enumerated elements Unallowed in Excel VBA?
As written in the comments, this is not possible. There is possible workaround though that I used in the past. Have:
Private Enum colType
ID = 1
SSN = 2
lName = 3
fName = 4
End Enum
And then create a separate String property of function such as:
Public Property Get colType_String(colType) as String
Dim v as Variant
v= Array("A","B", ...)
colType_String = vba.cstr(v(colType))
End Property
This is not the most universal solution, but it is easy to implement and it does the job... If you have this in the class module already you can even use property on private colType variable and there is no need to have colType input into the property.
I quite like ex-man's solution in certain circumstances, for which reason I've upvoted it. The solution more often posited goes along the following lines:
Enum myEnum
myName1 = 1
myName2 = 2
myName3 = 3
End Enum
Function getEnumName(eValue As myEnum)
Select Case eValue
Case 1
getEnumName = "myName1"
Case 2
getEnumName = "myName2"
Case 3
getEnumName = "myName3"
End Select
End Function
Debug.Print getEnumName(2) prints "myName2"
I have been searching for a very long time for the answer to this question. I do not want to have to relist the contents of an Enum in either a Case statement or an array. I couldn't find the answer, but I have managed to do after finding the code somewhere to change Module content. An alteration of that has produced the following working code, to be placed in Module1:
Option Explicit
Enum MensNames
Fred
Trev = 5
Steve
Bill = 27
Colin
Andy
End Enum
Sub EnumStringTest()
MsgBox EnumString(Steve) & " = " & Steve
End Sub
Function EnumString(EnumElement As MensNames) As String
Dim iLineNo As Integer
Dim iElementNo As Integer
iElementNo = 0
EnumString = vbNullString
With ThisWorkbook.VBProject.VBComponents("Module1").CodeModule
' Find the Enum Start
For iLineNo = 1 To .CountOfLines
If InStr(.Lines(iLineNo, 1), "Enum MensNames") > 0 Then
Exit For
End If
Next iLineNo
' Find the required Element
iLineNo = iLineNo + 1
Do While InStr(.Lines(iLineNo, 1), "End Enum") = 0 And .Lines(iLineNo, 1) <> ""
If InStr(2, .Lines(iLineNo, 1), "=") > 0 Then
iElementNo = CLng(Mid(.Lines(iLineNo, 1), InStr(2, .Lines(iLineNo, 1), "=") + 1))
End If
If iElementNo = EnumElement Then
EnumString = Left(Trim(.Lines(iLineNo, 1)), IIf(InStr(1, Trim(.Lines(iLineNo, 1)), " ") = 0, 1000, InStr(1, Trim(.Lines(iLineNo, 1)), " ") - 1))
Exit Do
End If
iElementNo = iElementNo + 1
iLineNo = iLineNo + 1
Loop
End With
End Function
To improve the solution of Rich Harding, I use the enum to improve on readability and make it less prone to mistakes:
Enum myEnum
myName
someOtherName
lastName
End Enum
Function getEnumName(eValue As myEnum) As String
Select Case eValue
Case myName: getEnumName = "myName"
Case someOtherName: getEnumName = "someOtherName"
Case lastName: getEnumName = "lastName"
End Select
End Function
The long integers in the Enum could be Base-10 encodings. The ToAlpha function below converts the number to Base-26, represented with uppercase alphabet characters. To get the number, call the ToLong function with a string.
This would work up to 6 characters (anything above 2,147,483,647 overflows the Enum value).
Private Enum colType
ID = 0 'A
SSN = 1 'B
lName = 7 'H
fName = 6 'G
WORD = 414859
FXSHRXX = 2147483647 'Maximum long
End Enum
Sub test()
Debug.Print "ID: " & ToAlpha(colType.ID)
Debug.Print "SSN: " & ToAlpha(colType.SSN)
Debug.Print "lName: " & ToAlpha(colType.lName)
Debug.Print "fName: " & ToAlpha(colType.fName)
Debug.Print "WORD: " & ToAlpha(colType.WORD)
Debug.Print "FXHRXX: " & ToAlpha(colType.FXSHRXX)
End Sub
Function ToAlpha(ByVal n)
If n < 0 Or Int(n) <> n Then Exit Function 'whole numbers only
Do While n > 25
ToAlpha = Chr(n Mod 26 + 65) & ToAlpha
n = n \ 26 - 1 'base 26
Loop
ToAlpha = Chr(n + 65) & ToAlpha
End Function
Function ToLong(ByVal s)
s = UCase(s)
Dim iC
For i = 1 To Len(s)
iC = Asc(Mid(s, i, 1))
If iC < 65 Or iC > 90 Then 'A-Z only
ToLong = -1
Exit Function
End If
ToLong = ToLong * 26 + (iC - 64) 'base 26
Next
ToLong = ToLong - 1
End Function
My solution of this looks like this:
Private Enum ColType
ID = 1
SSN = 2
lName = 3
fName = 4
End Enum
Private Function GetEnumName(ByVal value As ColType)
GetEnumName = Choose(value, _
"A", _
"B", _
"H", _
"G" _
)
End Function
Using Choose looks more tidy.
Sample usage: ... = GetEnumName(ColType.ID)
I hope this help
Reference: (Microsoft Visual Basic for Application Extensibility 5.3) is required
Public Enum SecurityLevel
IllegalEntry = 0
SecurityLevel1 = 1
SecurityLevel2 = 3
SecurityLevel3
SecurityLevel4 = 10
End Enum
Public Sub Test1()
Cells.Clear
Range("A1").Value = StrEnumVal("SecurityLevel", SecurityLevel.IllegalEntry)
Range("A2").Value = StrEnumVal("SecurityLevel", SecurityLevel.SecurityLevel1)
Range("A3").Value = StrEnumVal("SecurityLevel", SecurityLevel.SecurityLevel2)
Range("A4").Value = StrEnumVal("SecurityLevel", SecurityLevel.SecurityLevel3)
Range("A5").Value = StrEnumVal("SecurityLevel", SecurityLevel.SecurityLevel4)
End Sub
Public Sub AaaTest2()
Cells.Clear
Dim E As Long
For E = SecurityLevel.IllegalEntry To SecurityLevel.SecurityLevel4
Cells(E + 1, 1) = StrEnumVal("SecurityLevel", E)
Next
End Sub
Function StrEnumVal(BEnumName As String, EnumItm As Long) As String
'''''''''''''''''''''''''
' Fahad Mubark ALDOSSARY'
'''''''''''''''''''''''''
Dim vbcomp As VBComponent
Dim modules As Collection
Dim CodeMod As VBIDE.CodeModule
Dim numLines As Long ' end line
Dim MdlNm As String
Dim lineNum As Long
Dim thisLine As String, SpltEnm As String, EnumITems As String, Itm As String
Dim EEnumName As String
Dim Indx As Long
Dim I As Long, s As Long
Dim SpltEI As Variant
Indx = 0
Set modules = New Collection
BEnumName = "Enum " & BEnumName
EEnumName = "End Enum"
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
'if normal or class module
If vbcomp.Type = vbext_ct_StdModule Then
Set CodeMod = vbcomp.CodeModule
With CodeMod
numLines = .CountOfLines
For lineNum = 1 To numLines
thisLine = .Lines(lineNum, 1)
If InStr(1, thisLine, BEnumName, vbTextCompare) > 0 Then
If InStr(thisLine, ":") > 0 Then
' thisLine = Replace(thisLine, BEnumName & ":", "") ' Remove Enum Titel Enum
thisLine = Right(thisLine, Len(thisLine) - InStr(1, thisLine, ":"))
For s = 0 To UBound(Split(thisLine, ":"))
SpltEnm = Split(thisLine, ":")(s)
If InStr(SpltEnm, " = ") > 0 Then
Itm = SpltEnm
Indx = CDbl(Split(SpltEnm, " = ")(1))
Else
Itm = SpltEnm & " = " & Indx
End If
EnumITems = EnumITems & IIf(EnumITems <> "", vbNewLine, "") & Itm '''''
Indx = Indx + 1
Next
If InStr(1, thisLine, EEnumName, vbTextCompare) > 0 Then
EnumITems = Replace(EnumITems, "End Enum", "")
Exit For
End If
Else
'Only Title show if nothing bedside
End If
ElseIf InStr(1, thisLine, EEnumName, vbTextCompare) > 0 Then
If InStr(thisLine, ":") > 0 Then
For s = 0 To UBound(Split(thisLine, ":"))
SpltEnm = Split(thisLine, ":")(s)
If InStr(SpltEnm, " = ") > 0 Then
Itm = SpltEnm
Indx = CDbl(Split(SpltEnm, " = ")(1))
Else
Itm = SpltEnm & " = " & Indx
End If
EnumITems = EnumITems & IIf(EnumITems <> "", vbNewLine, "") & Itm '''''
EnumITems = Replace(EnumITems, "End Enum", "")
Indx = Indx + 1
Next
Else
End If
Exit For
Else
If InStr(thisLine, ":") > 0 Then
For s = 0 To UBound(Split(thisLine, ":"))
SpltEnm = Split(thisLine, ":")(s)
If InStr(SpltEnm, " = ") > 0 Then
Itm = SpltEnm
Indx = CDbl(Split(SpltEnm, " = ")(1))
Else
Itm = SpltEnm & " = " & Indx
End If
EnumITems = EnumITems & IIf(EnumITems <> "", vbNewLine, "") & Itm '''''
Indx = Indx + 1
Next
Else
If InStr(thisLine, " = ") > 0 Then
Itm = thisLine
Indx = Split(thisLine, " = ")(1)
Else
Itm = thisLine & " = " & Indx
End If
EnumITems = EnumITems & IIf(EnumITems <> "", vbNewLine, "") & Itm '''''
End If
Indx = Indx + 1
End If
Next lineNum
If InStr(1, thisLine, EEnumName, vbTextCompare) > 0 Then Exit For
End With 'CodeMod
End If
Next vbcomp
SpltEI = Split(EnumITems, vbNewLine)
For I = LBound(SpltEI) To UBound(SpltEI)
If CDbl(Replace(Split(SpltEI(I), " = ")(1), " ", "")) = EnumItm Then
StrEnumVal = Replace(Split(SpltEI(I), " = ")(0), " ", "")
Exit For
Else
End If
Next
End Function
To active Required Reference copy Below Code then delete it
enter image description here
Sub AddReferenceVBA()
AddRef ThisWorkbook, "{0002E157-0000-0000-C000-000000000046}", "VBIDE", 5, 3
End Sub
Sub AddRef(wbk As Workbook, sGuid As String, sRefName As String, sRefMajor As Long, sRefMinor As Long)
Dim I As Integer
On Error GoTo EH
With wbk.VBProject.References
For I = 1 To .Count
If .Item(I).Name = sRefName Then
Exit For
End If
Next I
If I > .Count Then
.AddFromGuid sGuid, sRefMajor, sRefMinor ' 0,0 should pick the latest version installed on the computer
ThisWorkbook.Save
End If
End With
EX: Exit Sub
EH: MsgBox "Error in 'AddRef'" & vbCrLf & vbCrLf & Err.Description
Resume EX
Resume ' debug code
End Sub
Updated and corrcted
Public Enum SecurityLevelp
IllegalEntry = 1
SecurityLVL1
SecurityLVL2 = 8
SecurityLVL3
SecurityLVL4 = 10
SecurityLVL5
SecurityLVL6 = 15
End Enum
Public Sub Test()
AddRef ThisWorkbook, "{0002E157-0000-0000-C000-000000000046}", "VBIDE", 5, 3 'if need or delete this line. To select required Reference
MsgBox GeEnumValues("SecurityLevelp", 1) 'to replace enum
MsgBox GeEnumValues("SecurityLevelp", SecurityLVL3) 'to replace enum
MsgBox GeEnumValues("SecurityLevelp", 11) 'to replace enum
MsgBox GeEnumValues("SecurityLevelp", SecurityLVL6) 'to replace enum
End Sub
Function GeEnumValues(PrcName As String, EnumItm As Long)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Reference:Microsoft Visual Basic for Extensibility 5.3 is required'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim ProcStrLn As Long, ProcAcStrLn As Long, ProcCntLn As Long, N As Long, D As Long, S As Long, PrcCnountLine As Long
Dim DecStrLn As Long, DecEndLn As Long
Dim ThisLine As String, Dec As String, ThisSub As String, Itm As String
Dim DecItm As Variant
Set VBProj = ThisWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
With VBComp
If .Type = vbext_ct_StdModule Then ' Withen Standr Module
With .CodeModule
If InStr(1, .Lines(1, .CountOfLines), PrcName) > 0 Then 'Replace Sub Function
On Error Resume Next
ProcStrLn = .ProcStartLine(PrcName, vbext_pk_Proc) ' Procedure Start Line
ProcAcStrLn = .ProcBodyLine(PrcName, vbext_pk_Proc) ' Actually Procedure Start Line
ProcCntLn = .ProcCountLines(PrcName, vbext_pk_Proc)
PrcCnountLine = ProcCntLn - (ProcAcStrLn - ProcStrLn)
If ProcAcStrLn > 0 Then
'If PrcName = .ProcOfLine(ProcAcStrLn, vbext_pk_Proc) Then 'Get Proce Name
' For N = (ProcAcStrLn + 1) To (ProcAcStrLn + PrcCnountLine - 1) ' Add 1 to avoid chane Procedure Name and -1 to avoid replace Next Procedure
' ThisLine = .Lines(N, 1)
' If InStr(N, ThisLine, Fnd, vbTextCompare) > 0 Then
'ThisSub = ThisSub & vbNewLine & ThisLine
'End If
'Next
' End If
Else '____________________________________________________________________________________________________
' Replce Declaration such as Enum
For D = 1 To .CountOfDeclarationLines
ThisLine = .Lines(D, 1)
If InStr(1, ThisLine, "Enum " & PrcName) > 0 Then
Titl = DecItm(D)
Dec = Dec & vbNewLine & ThisLine: DecStrLn = D
S = InStr(1, ThisLine, "Enum " & PrcName) + Len("Enum " & PrcName) 'Start replace column
ElseIf InStr(1, Dec, "Enum " & PrcName) > 0 And InStr(1, ThisLine, "End Enum") > 0 Then
Dec = Dec & vbNewLine & ThisLine: DecEndLn = D
Exit For
ElseIf InStr(1, Dec, "Enum " & PrcName) Then
Dec = Dec & vbNewLine & ThisLine
End If
Next 'Declaration
' MsgBox .Lines(DecStrLn, DecEndLn - DecStrLn + 1) '=MsgBox Dec 'Declaration
End If '_______________________________________________________________________________________________________
On Error GoTo 0
End If
End With ' .CodeModule
End If ' .Type
End With ' VBComp
Next ' In VBProj.VBComponents
'Declaration
DecItm = Split(Dec, vbNewLine)
For D = LBound(DecItm) To UBound(DecItm)
Itm = DecItm(D)
If Itm <> "" And InStr(1, Itm, "Enum " & PrcName, vbTextCompare) = 0 And InStr(1, Itm, "End Enum") = 0 Then
If InStr(1, Itm, " = ", vbTextCompare) > 0 Then
N = Split(Itm, " = ")(1)
Else
Itm = Itm & " = " & N
End If
If EnumItm = N Then
GeEnumValues = Trim(Split(Itm, " = ")(0))
Exit Function
End If
N = N + 1
End If
Next
End Function
' if needed o delte below code
Sub AddRef(wbk As Workbook, sGuid As String, sRefName As String, sRefMajor As Long, sRefMinor As Long)
Dim i As Integer
On Error GoTo EH
With wbk.VBProject.References
For i = 1 To .Count
If .Item(i).Name = sRefName Then
Exit For
End If
Next i
If i > .Count Then
.AddFromGuid sGuid, sRefMajor, sRefMinor ' 0,0 should pick the latest version installed on the computer
End If
End With
EX: Exit Sub
EH: MsgBox "Error in 'AddRef'" & vbCrLf & vbCrLf & Err.Description
Resume EX
Resume ' debug code
ThisWorkbook.Save
End Sub
Instead of Enum, define a Type(struct)
Public Type colType
ID As String
SSN As String
lName As String
fName As String
End Type
And then create a object of type colType and set desired values to it.
Public myColType As colType
myColType.ID = "A"
myColType.SSN = "B"
myColType.lname = "H"
myColType.fName = "G"

Resources