I have recently come to use VBA class modules in my code.
Based in part on an answer on Stack Overflow, I bought VBA Developer's Handbook and Professional Excel Development, but it took me a long time to 'get' classes (though I still have a long way to go).
I wrote myself a GetExternalData class, as one of the very common tasks I undertake in Excel VBA is incorporating data from other sources into my reports.
My thought was that the class could take care of deciding the best way of getting the data, based on the source and how the data is to be used, so my getExternalData method was using a 'Variant' so that I could use the same variable whether I return a Collection, Array, Dictionary or Worksheet.
However, when I attempted to pass the Collection to another function which expects a collection I was getting an error. I noticed the locals window showed as 'Variant/Object/Collection', so I tried setting the value to an Object rather than a Variant which works.
My question on Stack Overflow was actually about this practice (Dim as Object... set = Collection).
TODO:
At the moment, I don't have anything coded for Access database connections
I check the first element of a collection, and assume all items are similar types and have the same number of elements (for arrays)
I know there's debate on the merits of Hungarian - at the moment, I find it useful (have been using it for a long time in Access (tbl, qry) and in VBA user-forms (txt, cmb), so implementing it into my VBA made sense - so I don't really want to get into that debate
There's also mixed opinion on accessors vs public variables. If I create a letter then I create a getter, except where I'm storing the return Cols in a collection
Option Explicit
Public Enum dataReturnType
arrayVals
collectionVals
dictionaryVals
End Enum
Public Enum sourceFileType
csv = 1 '
xls = 10 'old Excel
mdb 'old Access
xlsx = 100 'new Excel
xlsm 'new Excel macro-enabled
accdb 'new Access
End Enum
Private Enum getDataMethod
ADO_Record_Set
Web_QT
End Enum
Private strFilePath As String
Private strFileName As String
Private enumFileType As sourceFileType
Private strConnString As String
Private strExtendedProperties As String
Private strSelectClause As String
Private strFromClause As String
Private colReturnFields As Collection
Private enumRetrievalMethod As getDataMethod
Private strFormatString As String
Private boolIMEX As Boolean
Private boolHDR As Boolean
Private intkeyCol As Integer
Private rngOutput as Range
Public WSname As String
Public WhereClause As String
Public RtnType As dataReturnType
Private Sub Class_Initialize()
boolHDR = True
boolIMEX = True
Set colReturnFields = New Collection
strSelectClause = "*"
End Sub
Property Let FilePath(fullPathOnly As String)
If Left(fullPathOnly, 4) = "http" Then
enumRetrievalMethod = Web_QT
If Right(fullPathOnly, 1) = "/" Then strFilePath = fullPathOnly Else strFilePath = fullPathOnly & "/"
Else
enumRetrievalMethod = ADO_Record_Set
If Right(fullPathOnly, 1) = "\" Then strFilePath = fullPathOnly Else strFilePath = fullPathOnly & "\"
End If
End Property
Property Get FilePath() As String
FilePath = strFilePath
End Property
Property Let FileName(fName As String)
strFileName = fName
Select Case Right(strFileName, Len(strFileName) - InStr(strFileName, "."))
Case Is = "txt", "csv", "lst"
enumFileType = csv
Case Is = "xls"
enumFileType = xls
Case Is = "xlsx", "xlsb"
enumFileType = xlsx
Case Is = "xlsm"
enumFileType = xlsm
Case Is = "mdb"
enumFileType = mdb
Case Is = "accdb"
enumFileType = accdb
End Select
End Property
Property Get FileName() As String
FileName = strFileName
End Property
Property Let ReturnFields(colNums As Variant)
Dim colNum As Variant
Select Case VarType(colNums)
Case Is < vbVariant
colReturnFields.Add colNums
Case Else
For Each colNum In colNums
colReturnFields.Add colNum
Next
End Select
End Property
Property Let externalDataKeyColumn(colNum As Integer)
intkeyCol = colNum
End Property
Property Get externalDataKeyColumn() As Integer
externalDataKeyColumn = intkeyCol
End Property
Public Function getExternalData() As Variant
Dim ReturnVals As Object
Dim DataProcessor As Object
Set DataProcessor = New DataProcessor
Select Case enumRetrievalMethod
Case Is = getDataMethod.ADO_Record_Set
Set ReturnVals = doConnectRS
Select Case Me.RtnType
Case Is = dataReturnType.arrayVals
getExternalData = DataProcessor.collection2Array(ReturnVals, Me.externalDataKeyColumn, True)
Case Is = collectionVals
Set getExternalData = ReturnVals
Case Is = dictionaryVals
Set getExternalData = New scripting.Dictionary
Set getExternalData = DataProcessor.collection2Dictionary(ReturnVals, Me.externalDataKeyColumn)
End Select
Case Is = getDataMethod.Web_QT
Set ReturnVals = doConnectQT
Select Case Me.RtnType
Case Is = dataReturnType.arrayVals
getExternalData = ReturnVals.UsedRange
Case Is = collectionVals
Set getExternalData = DataProcessor.array2Collection(ReturnVals.UsedRange, Me.externalDataKeyColumn)
Case Is = dictionaryVals
Set getExternalData = DataProcessor.array2Dictionary(ReturnVals.UsedRange, Me.externalDataKeyColumn)
End Select
End Select
End Function
Private Function doConnectRS() As Collection
'RecordSet Constants
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Dim dp As New DataProcessor
Dim objRecordSet As Object, objConnection As Object
Dim varRS As Variant
Dim connString As String, SqlStatement As String
Dim colNum As Integer, rowNum As Integer
Dim colRS As New Collection
Dim keyCol As Variant
If Not compatibleSource Then Exit Function
connString = getConnectionProperties
SqlStatement = "Select " & strSelectClause & " FROM " & strFromClause
If WhereClause <> vbNullString Then SqlStatement = SqlStatement & " WHERE " & WhereClause
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")
objConnection.Open connString
objRecordSet.Open SqlStatement, objConnection, adOpenStatic, adLockOptimistic, adCmdText
If colReturnFields.Item(1) = "all" Then
colReturnFields.Remove (1)
For colNum = 1 To objRecordSet.Fields.Count
colReturnFields.Add colNum
Next
End If
Do Until objRecordSet.EOF
ReDim varRS(1 To colReturnFields.Count)
For colNum = 1 To colReturnFields.Count
If IsNull(objRecordSet.Fields.Item(CLng(colReturnFields.Item(colNum) - 1))) Then
varRS(colNum) = vbNullString 'If the SQL statement returns Null populate with vbNullString rather than Null
Else
varRS(colNum) = objRecordSet.Fields.Item(CLng(colReturnFields.Item(colNum) - 1))
End If
Next
colRS.Add varRS
objRecordSet.MoveNext
Loop
Set objRecordSet = Nothing
Set objConnection = Nothing
Set doConnectRS = colRS
End Function
Private Function compatibleSource() As Boolean
Select Case enumFileType
Case Is > xlsx
If Application.Version < 12 Then
MsgBox "Incompatible source file selected!", vbCritical
compatibleSource = False
Else
compatibleSource = True
End If
Case Else
compatibleSource = True
End Select
End Function
Private Function getConnectionProperties()
Dim HDR As String
If boolHDR Then HDR = "HDR=YES" Else HDR = "HDR=NO"
Select Case enumFileType
Case Is = xls
strConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFilePath & strFileName & ";"
strExtendedProperties = "Extended Properties=""Excel 8.0;"
strFromClause = "[" & WSname & "$]"
Case Is = csv
strConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFilePath & ";"
strExtendedProperties = "Extended Properties=""text; FMT=Delimited;"
strFromClause = strFileName
Case Is = xlsx
strConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & strFileName & ";"
strExtendedProperties = "Extended Properties=""Excel 12.0 Xml;"
strFromClause = "[" & WSname & "$]"
Case Is = xlsm
strConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & strFileName & ";"
strExtendedProperties = "Extended Properties=""Excel 12.0 Macro;"
strFromClause = "[" & WSname & "$]"
End Select
getConnectionProperties = strConnString & strExtendedProperties & HDR & ";"
If boolIMEX Then getConnectionProperties = getConnectionProperties & "IMEX=1;"
getConnectionProperties = getConnectionProperties & """"
End Function
Private Function doConnectQT() As Worksheet
Dim ws As Worksheet
Dim qT As QueryTable
If rngOutput Is Nothing Then
Set ws = Worksheets.Add
Set rngOutput = ws.Range("a1")
Else
Set ws = rngOutput.Parent
End If
myFileName = "URL; " & Me.FilePath & Me.FileName
Set qT = ws.QueryTables.Add(Connection:=myFileName, Destination:=rngOutput)
With qT
.Name = "myQT"
.fieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
qT.Delete
Set doConnectQT = ws
End Function
For the sake of completeness, I will also post the 'DataProcessor' class which I use to convert the returned collection to a dictionary or array if needed
Public Function collection2Array(colIn As Collection, Optional ByVal keyCol As Integer, Optional writeOut As Boolean) As Variant
Dim rowCount As Long, colCount As Long
Dim arrOut As Variant
Select Case VarType(colIn.Item(1))
Case Is >= vbVariant 'if the collection contains arrays
ReDim arrOut(1 To colIn.Count, 1 To UBound(colIn.Item(1))))
For rowCount = 1 To UBound(colIn.Item(1))
For colCount = 1 To UBound(arrOut, 2)
arrOut(rowCount, colCount) = colIn.Item(rowCount)(colCount)
Next
Next
Case Else
If writeOut Then 'we'll return a 2D array with 1 column suitable for writing directly to a worksheet
ReDim arrOut(1 To colIn.Count, 1 To 1)
For rowCount = 1 To colIn.Count
arrOut(rowCount, 1) = colIn.Item(rowCount)
Next
Else
ReDim arrOut(1 To colIn.Count)
For rowCount = 1 To colIn.Count
arrOut(rowCount) = colIn.Item(rowCount)
Next
End If
End Select
collection2Array = arrOut
End Function
Public Function collection2Dictionary(colIn As Collection, Optional ByVal keyCol As Integer, Optional compareMode As VbCompareMethod = vbTextCompare) As scripting.Dictionary
Dim colVal As Variant
Set collection2Dictionary = New scripting.Dictionary
collection2Dictionary.compareMode = compareMode
If keyCol = 0 Then keyCol = 1
For Each colVal In colIn
collection2Dictionary.Item(colVal(keyCol)) = colVal
Next
End Function
Integeris not worth the clutter. Knowing that something is an array index, though, or a combo box, that's more useful. I recommend the excellent Joel Spolsky post on the topic: joelonsoftware.com/articles/Wrong.html \$\endgroup\$strConnoteNumberandstrRunNoleave no ambiguity as to what data-type they actually are \$\endgroup\$