It’s a bit frustrating if you have to select any NoBlank cells (both xlCellTypeConstants and xlCellTypeFormulas) using the SpecialCells Method, as there is not one constant that handles both of them, and it goes throwing errors if any range Is Nothing. So here is the code to properly select no blank cells. You can also combine with Selection range and with formated cells to refine more the selection.
Category: Sin categoría
HTML Table to XLS
Just a little parser. It is also shown how to delete an HTML Element:
The program requires references to the following:
- Microsoft Internet Controls
- Microsoft Shell Controls and Automation (for Internet Explorer Medium)
- Microsoft HTML Object Library
Excel to App (with VBA macros)
This is a continuation (or better, a prologue) of this post, where I’m trying to accomplish an “Excel to web App” solution that can handle macros (VBA to JavaScript). It’s only shown a little piece of code on how to get an “If” block to JS, but there is more done waiting to create an online service to be published.
Continue reading “Excel to App (with VBA macros)”
LEAN
Introduction
The Lean Production presents an alternative vision of conventional production, introducing a novel approach that is taking more strength every day worldwide. This new perspective, based on the Toyota Production System (TPS), addresses the causes of many of the problems that limit efficiency, focusing on the reduction of losses along the productive flow, minimizing waste and adding systematically value the manufacturing process. I’ll not bother you about the history of the LEAN philosophy, you can check it in Wikipedia article. The philosophy behind LEAN is the ‘Total Productive Maintenance’ or ‘Total Productive Manufacturing’, and for TOTAL, meaning ‘total participation’ – that’s, everyone in the company – playing an active role in productive flow, adding value to the organization by developing its own staff and associated (suppliers and subcontractors) and continuously solve root problems generating organizational learning. The goal of the system is to eliminate “waste” or “loss” (Muda in Japanese). I would recomend the following site to get more information about LEAN and TPM.BIM
Introduction
BIM (Building Information Modelling, or let’s say it, Management) is the “digital” language with which the Construction sector should be able to produce more efficiently. It will cause a deep digitalization of all procedures and stages, and implies a interdisciplinary collaboration, supported by new technologies, that can bring more efficiency in the job done. So, it’s very likely to be the most important revolution that this sector has experienced. Digitization gives the opportunity to bring, to the Construction sector, values of industrial production that allow access to higher levels of quality, control, traceability, productivity and efficiency, which should help achieve a more sustainable activity. But don’t get me wrong, the use of a specific technology is not, by itselft, a guarantee to a better work; regardless of the technology they use, the work depends on the professionals using it, and how they use it. One final thing to note, with which we have started. BIM stands for:- “Building” (or “construction”, and even the action of “build”),
- “Information”, relating it with classified, stored data, with the capacity to be transmitted and later processed with computer technology.
- “Modelling”, relating to a 3D representation model or simplified idealization of something. But we must consider here that BIM methodology, in the end, is more related to the global management of the whole “building”, throughout the phases of life (planning, project, construction and exploitation).
Current situation
The Construction sector has some peculiarities:- Low productivity indexes.
- Significant specific weight in the economy of any country.
- Mobilizes a very significant and diversified workforce.
- Operates in a very sequential manner, with agents that intervene with very heterogeneous levels of interconnection.
- Increasingly demanding regulations
- Complex technical facilities
- Need to reduce energy needs
- Introduction of ecodesign
- Introduction of sensorics and efficient management
- Reduction of environmental impacts
- Greater demand for quality
- Elimination of unforeseen extra costs
- Adjusted control of temporary schedules
- From the technological point of view, we have to see it as a set of software applications and information hosting systems that can allow more efficient production work. New technologies tools arise in a linear way, and are usually adopted continuously without producing large jumps in the way of operating.
- From the point of view as a process, it supposes the establishment of a work of collaboration between the diverse interested parties, that covers all the cycle of life, being based on the new software and the technologies of communication. The change in a process is an always more disruptive factor.
- the scarce industrialization of processes,
- the atomization of industry,
- poorly collaborative work systems,
- poorly qualified labor,
- a difficult capitalization of knowledge acquired in daily practice,
- the rigidity of contracting systems,
- sequentiality,
- etc.
Sequentiality
There is an inefficiency when each agent enters and leaves the project at a specific time, having had a very low level of dialogue with respect to the other agents. If they do not dialogue, they probably can not contrast the different criteria in early phases, when it is easy to make decisions. Worse still, if the time they are tied to the project is short, they will never get a global vision that can lead to better options. It’s needed a more imbricated implication of the stakeholders, with the intensity representing their role in the project, based on their experience, in the initial stages of development when decisions are more efficient and involve a lower cost. Introducing changes on the fly in the construction phase is inefficient, and can derive in clashes not well pondered.Integrated Project Delivery
The IPD (Integrated Project Delivery) methodology. Is about making decisions based on the experience of the different agents, in the initial stages of development of a project, just when making decisions, and changes in criteria, are more efficient and involve a lower cost.The alignment of interests
A certain cultural change is desirable, in which the different agents understand the need to work as a team that aims for a common goal. This is a cultural shift hard to achieve, as business practice is conducted by each agent seeking its own maximum economic benefit, that does not have to favor the project considered globally. Therefore, each stakeholder applies resources and strategies that, even being favorable to their particular interest, it can be detrimental to other agents, or even to the final outcome of the project. To overcome this difficulty, the problem of sequentiality must be solved, forcing the different agents to collaborate during the different phases of the project. Ideally this could be achieved by the parties understanding that they will achieve a greater particular benefit by acting together than acting separately; or, directly, forcing collaboration. Current business models, and hiring, clash with this idea.The complete life-cycle
All the stakeholders should consider the project as the sum of all the phases through which an asset passes: Planning, Design, Construction, Exploitation and End of useful life, and not only taking to consideration the part in which they are affected and bounded to it.BIM benefits:
- Information about all the elements can be used throughout the building lifecycle from construction to maintenance.
- Provides a 3D model that serves as a centralized location for all the parties involved to put in and pull out the information.
- Provides a 4D model that is used for scheduling during construction, modification and maintenance phase.
- Provides a 5D model to reduce the expenses and maintenance costs.
- Provides a 6D model to answer all the questions like who, what, when, and how of the different aspects of the building lifecycle.
Benefits of BIM for facility management:
- Space Management: BIM gives a proper know-how of the space used thus increasing the scope of reducing vacant spaces. Ultimately, it reduces the expenses required for maintenance.
- Efficient Maintenance: Maintenance of information becomes tough when a large amount of data is involved in big projects. BIM eliminates months of work by providing a streamlined maintenance of the information.
- Efficient Energy Usage: Through BIM, facility managers can avoid negative impacts on the environment by helping find energy alternatives. Hence, it optimizes the building performance.
- Affordable Renovations: BIM Services help in providing better information on the existing state of the project. Hence, reducing the complexity, time and money required to renovate it.
- Lifecycle Management: BIM supports an in-depth knowledge of the materials to be used for lower maintenance cost. Some materials are costly compared to others but they are more durable hence reducing the overall lifecycle costs.
VBA decode URI data
It’s not only img block that accepts Data URIs, in HTML5 audio and video also accept it as a source, as well as standard file URLs.
URI information has this form:
data:[<MIME-type>][;charset=<encoding>][;base64],<data>Would be interesting to hide -hindering download- some graphical elements as binary text, thus needed to encode/decode. So rearranging code from here got a functional tool for this task.
Option Explicit
Private Const clOneMask As Long = 16515072 '000000 111111 111111 111111
Private Const clTwoMask As Long = 258048 '111111 000000 111111 111111
Private Const clThreeMask As Long = 4032 '111111 111111 000000 111111
Private Const clFourMask As Long = 63 '111111 111111 111111 000000
Private Const clHighMask As Long = 16711680 '11111111 00000000 00000000
Private Const clMidMask As Long = 65280 '00000000 11111111 00000000
Private Const clLowMask As Long = 255 '00000000 00000000 11111111
Private Const cl2Exp18 As Long = 262144 '2 to the 18th power
Private Const cl2Exp12 As Long = 4096 '2 to the 12th
Private Const cl2Exp6 As Long = 64 '2 to the 6th
Private Const cl2Exp8 As Long = 256 '2 to the 8th
Private Const cl2Exp16 As Long = 65536 '2 to the 16th
Public Sub sFileEncode64()
Dim iFileIn As Integer
Dim strFullPathFile As String
Dim sBinary As String
iFileIn = VBA.FreeFile()
strFullPathFile = VBA.Environ$("UserProfile") & "\Documents\###." & "png"
Open strFullPathFile For Binary As #iFileIn
sBinary = String$(LOF(iFileIn), Chr$(0))
Get #iFileIn, , sBinary
Close #iFileIn
Debug.Print Encode64(sBinary)
End Sub
Public Function sTest_DecodeURI()
Dim strURI As String
strURI = _
"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABYAAAAWCAYAAADEtGw7AAAABGdBTUEAALGPC/xhBQAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9oEBxcZFmGboiwAAAAIdEVYdENvbW1lbnQA9syWvwAAAuFJREFUOMvtlUtsjFEUx//n3nn0YdpBh1abRpt4LFqtqkc3jRKkNEIsiIRIBBEhJJpKlIVo4m1RRMKKjQiRMJRUqUdKPT71qpIpiRKPaqdF55tv5vvusZjQTjOlseUkd3Xu/3dPzusC/22wtu2wRn+jG5So/OCDh8ycMJDflehMlkJkVK7KUYN+ufzA/RttH76zaVocDptRxzQtNi3mRWuPc+6cKtlXZ/sddP2uu9uXlmYXZ6Qm8v4Tz8lhF1H+zDQXt7S8oLMXtbF4e8QaFHjj3kbP2MzkktHpiTjp9VH6iHiA+whtAsX5brpwueMGdONdf/2A4M7ukDs1JW662+XkqTkeUoqjKtOjm2h53YFL15pSJ04Zc94wdtibr26fXlC2mzRvBccEbz2kiRFD414tKMlEZbVGT33+qCoHgha81SWYsew0r1uzfNylmtpx80pngQQ91LwVk2JGvGnfvZG6YcYRAT16GFtW5kKKfo1EQLtfh5Q2etT0BIWF+aitq4fDbk+ImYo1OxvGF03waFJQvBCkvDffRyEtxQiFFYgAZTHS0zwAGD7fG5TNnYNTp8/FzvGwJOfmgG7GOx0SAKKgQgDMgKBI0NJGMEImpGDk5+WACEwEd0ywblhGUZ4Hw5OdUekRBLT7DTgdEgxACsIznx8zpmWh7k4rkpJcuHDxCul6MDsmmBXDlWCH2+XozSgBnzsNCEE4euYV4pwCpsWYPW0UHDYBKSWu1NYjENDReqtKjwn2+zvtTc1vMSTB/mvev/WEYSlASsLimcOhOBJxw+N3aP/" & _
"SjefNL5GePZmpu4kG7OPr1+tOfPyUu3BecWYKcwQcDFmwFKAUo90fhKDInBCAmvqnyMgqUEagQwCoHBDc1rjv9pIlD8IbVkz6qYViIBQGTJPx4k0XpIgEZoRN1Da0cij4VfR0ta3WvBXH/rjdCufv6R2zPgPH/e4pxSBCpeatqPrjNiso203/5s/zA171Mv8+w1LOAAAAAElFTkSuQmCC"
Call Decode64(strURI)
End Function
Public Function Encode64(ByVal sString As String) As String
Dim bTrans(63) As Byte
Dim lPowers8(255) As Long
Dim lPowers16(255) As Long
Dim bOut() As Byte
Dim bIn() As Byte
Dim lChar As Long
Dim lTrip As Long
Dim iPad As Integer
Dim lLen As Long
Dim lTemp As Long
Dim lPos As Long
Dim lOutSize As Long
For lTemp = 0 To 63 'Fill the translation table.
Select Case lTemp
Case 0 To 25
bTrans(lTemp) = 65 + lTemp 'A - Z
Case 26 To 51
bTrans(lTemp) = 71 + lTemp 'a - z
Case 52 To 61
bTrans(lTemp) = lTemp - 4 '1 - 0
Case 62
bTrans(lTemp) = 43 'Chr(43) = "+"
Case 63
bTrans(lTemp) = 47 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables.
lPowers8(lTemp) = lTemp * cl2Exp8
lPowers16(lTemp) = lTemp * cl2Exp16
Next lTemp
iPad = Len(sString) Mod 3 'See if the length is divisible by 3
If iPad Then 'If not, figure out the end pad and resize the input.
iPad = 3 - iPad
sString = sString & String(iPad, Chr(0))
End If
bIn = StrConv(sString, vbFromUnicode) 'Load the input string.
lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string.
lTemp = lLen \ 72 'Added space for vbCrLfs.
lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer.
ReDim bOut(lOutSize) 'Make the output buffer.
lLen = 0 'Reusing this one, so reset it.
For lChar = LBound(bIn) To UBound(bIn) Step 3
lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes
lTemp = lTrip And clOneMask 'Mask for the first 6 bits
bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value
lTemp = lTrip And clTwoMask 'Mask for the second set.
bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate.
lTemp = lTrip And clThreeMask 'Mask for the third set.
bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate.
bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set.
If lLen = 68 Then 'Ready for a newline
bOut(lPos + 4) = 13 'Chr(13) = vbCr
bOut(lPos + 5) = 10 'Chr(10) = vbLf
lLen = 0 'Reset the counter
lPos = lPos + 6
Else
lLen = lLen + 4
lPos = lPos + 4
End If
Next lChar
If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
If iPad = 1 Then 'Add the padding chars if any.
bOut(lOutSize) = 61 'Chr(61) = "="
ElseIf iPad = 2 Then
bOut(lOutSize) = 61
bOut(lOutSize - 1) = 61
End If
Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it.
End Function
Public Function Decode64(ByVal sString As String) As Boolean
Dim lgPosition As Long
Dim strURI As String
Dim strMIMEtype As String
Dim strData As String
'data:[][;charset=][;base64],
'data:image/png;base64,
'data:audio/ogg;base64,
'data:video/webm;base64,
'data:video/mp4;base64,
lgPosition = 1
lgPosition = VBA.InStr(lgPosition, sString, "/")
strMIMEtype = VBA.Mid$(sString, lgPosition + 1, VBA.InStr(lgPosition, sString, ";") - lgPosition - 1)
sString = VBA.Mid$(sString, VBA.InStr(1, sString, ",") + 1)
Dim bOut() As Byte
Dim bIn() As Byte
Dim bTrans(255) As Byte
Dim lPowers6(63) As Long
Dim lPowers12(63) As Long
Dim lPowers18(63) As Long
Dim lQuad As Long
Dim iPad As Integer
Dim lChar As Long
Dim lPos As Long
Dim lTemp As Long
Dim lgRetVal As Long
sString = Replace(sString, vbCr, vbNullString) 'Get rid of the vbCrLfs. These could be in...
sString = Replace(sString, vbLf, vbNullString) 'either order.
lTemp = Len(sString) Mod 4 'Test for valid input.
If lTemp Then
GoTo ErrControl
'Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
End If
If InStrRev(sString, "==") Then 'InStrRev is faster when you know it's at the end.
iPad = 2 'Note: These translate to 0, so you can leave them...
ElseIf InStrRev(sString, "=") Then 'in the string and just resize the output.
iPad = 1
End If
For lTemp = 0 To 255 'Fill the translation table.
Select Case lTemp
Case 65 To 90
bTrans(lTemp) = lTemp - 65 'A - Z
Case 97 To 122
bTrans(lTemp) = lTemp - 71 'a - z
Case 48 To 57
bTrans(lTemp) = lTemp + 4 '1 - 0
Case 43
bTrans(lTemp) = 62 'Chr(43) = "+"
Case 47
bTrans(lTemp) = 63 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 63 'Fill the 2^6, 2^12, and 2^18 lookup tables.
lPowers6(lTemp) = lTemp * cl2Exp6
lPowers12(lTemp) = lTemp * cl2Exp12
lPowers18(lTemp) = lTemp * cl2Exp18
Next lTemp
bIn = StrConv(sString, vbFromUnicode) 'Load the input byte array.
ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1) 'Prepare the output buffer.
For lChar = 0 To UBound(bIn) Step 4
lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3)) 'Rebuild the bits.
lTemp = lQuad And clHighMask 'Mask for the first byte
bOut(lPos) = lTemp \ cl2Exp16 'Shift it down
lTemp = lQuad And clMidMask 'Mask for the second byte
bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down
bOut(lPos + 2) = lQuad And clLowMask 'Mask for the third byte
lPos = lPos + 3
Next lChar
If iPad Then
ReDim Preserve bOut(LBound(bOut) To UBound(bOut) - iPad) 'Chop off any extra bytes.
End If
Dim iFileOut As Integer
iFileOut = VBA.FreeFile()
Open VBA.Environ$("UserProfile") & "\Documents\###." & strMIMEtype For Binary As #iFileOut
Put #iFileOut, , bOut()
Close #iFileOut
'StrConv(bOut, vbUnicode) 'Convert back to a string.
Decode64 = True
ExitProc:
Exit Function
ErrControl:
lgRetVal = VBA.MsgBox("Input string is not valid Base64.", vbCritical, "W A R N I N G")
GoTo ExitProc
End Function
VBA validation list values
If you want to get the values that cell valuation can handle, use this piece of code:
Private Sub sGetValidationList()
If Intersect(ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation), Selection) Is Nothing Then
Else
Call fGetValidationList(Selection, ";")
End If
End Sub
Private Function fGetValidationList(ByVal Target As Excel.Range, _
Optional ByVal strSeparator As String = ",") As String()
Dim rgList As Range
Dim strList As String
Dim strWsh As String
Dim lgPosition As Long
Dim aValidation() As String
Dim myVar As Variant
Dim myItem As Variant
Dim lgItem As Long
If Intersect(Target.Parent.Cells.SpecialCells(xlCellTypeAllValidation), Target) Is Nothing Then
Else
' Get the formula in the data validation
strList = Target.Validation.Formula1
' Check if it has an = sign (case has a range or a named range)
If VBA.InStr(1, strList, "=") > 0 Then
lgPosition = VBA.InStr(1, strList, "!")
If lgPosition > 0 Then
lgPosition = 1
strWsh = VBA.Mid$(strList, 1, VBA.InStr(1, strList, "!") - 1)
strWsh = VBA.Replace$(strWsh, "=", "")
strWsh = VBA.Replace$(strWsh, "'", "")
strList = VBA.Mid$(strList, VBA.InStr(1, strList, "!") + 1)
myVar = ThisWorkbook.Worksheets(strWsh).Range(strList).Value2
Else
myVar = Target.Parent.Range(VBA.Replace$(strList, "=", "")).Value2
End If
Else
' Case with a set of valid values
If InStr(1, strList, strSeparator) > 0 Then
myVar = Split(strList, strSeparator)
Else
aValidation = VBA.Split(strList, vbCrLf)
End If
End If
ReDim Preserve aValidation(LBound(myVar, 1) To UBound(myVar, 1))
lgItem = LBound(aValidation) - 1
For Each myItem In myVar
lgItem = lgItem + 1
aValidation(lgItem) = myItem
Next myItem
Erase myVar
fGetValidationList = aValidation
End If
End Function
[/sourcecode]
JavaScript: editable and resizable table
I’m a complete newbie in JavaScript language, but I’m trying to get on it. For long I’ve wondering if via JavaScript an HTML cable can be edited and resized (not only by means of shape, but to add rows and columns).
So asking google I reached some pages where code were exposed. Some were for resizing, some were for editing, some were for adding rows and other to add columns, and finally others were for sort and reorder elements. They were so interesting alone for themselves, that I supposed that combined, they will be ashtonishing. So did I. And here is the final code (the source links from were the codes came from are referred as comments in the code).
As there is something wrong with the javaScript code parser of wordpress, the code is linked in this file.
Database maker
In last post we were talking about how to distinguish between type of variables. From there, we can try to see if for any given table we can extract characteristics and mount a functional analysis of the database from a sample set of the table.
For that to be achieved, something like the following Database analyser can be used. It will also detect link to Names so data can be restricted to some sources.
Note: it needs the functions from this post.
Option Explicit
Private Const g_Base As Long = 0
Private Sub sDataBase_Analyzer()
' Given a database table, characterize the fields
Dim rgTable As Excel.Range
Dim rgHeaders As Excel.Range
Dim rgColumn As Excel.Range
Dim oCell As Excel.Range
Dim oCellLinked As Excel.Range
Dim rgFormulas As Excel.Range
Dim oName As Excel.Name
Dim bName As Boolean
Dim bHeaders As Boolean
Dim aField() As String
Dim aCarrousel() As String
Dim lgField As Long
Dim strField As String
Dim lgDeclaration As Long
Dim lgDeclarationOld As Long
Dim lgItem As Long
Dim lgCarrousel As Long
Dim bCarrousel As Boolean
Set rgTable = Selection 'Application.InputBox(Prompt:="Select table", Title:="", Type:=8, Default:="$A$1")
If vbYes = VBA.MsgBox("Table has headers?", vbYesNo, "Headers on first row?") Then bHeaders = True
ReDim Preserve aField(g_Base To rgTable.Columns.Count - 1 + g_Base)
lgField = g_Base - 1
If bHeaders Then
Set rgHeaders = rgTable.Rows(1)
For Each oCell In rgHeaders.Columns.Cells
If Not IsEmpty(oCell) Then
lgField = lgField + 1
strField = VBA.Trim$(oCell.Value2)
strField = VBA.Replace$(strField, " ", "_")
aField(lgField) = strField
' Capitalize string...
'.............ToDo
End If
Next oCell
End If
lgField = g_Base - 1
For Each rgColumn In rgTable.Columns
lgDeclaration = 0
If Not IsEmpty(rgColumn.Value2(1, 1)) Then
lgField = lgField + 1
lgCarrousel = g_Base - 1
For Each oCell In rgColumn.Cells
If (bHeaders And oCell.Row = rgHeaders.Row) Then
lgDeclarationOld = VarDeclaration(oCell.Offset(1, 0).Value2)
Else
If Not IsEmpty(oCell) Then
lgDeclaration = VarDeclaration(oCell.value)
If VBA.Abs(lgDeclarationOld) < VBA.Abs(lgDeclarationOld) Then
If lgDeclarationOld = 32768 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Integer", " As Long")
Exit For
End If
ElseIf Not bHeaders Then
If VBA.Abs(oCell.value) >= 32768 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Integer", " As Long")
Exit For
End If
End If
Next oCell
Case Is = 2
aField(lgField) = aField(lgField) & " As Double"
' Find typical values:
For Each oCell In rgColumn.Cells
If Not (bHeaders And oCell.Row = rgHeaders.Row) Then
If 1.401298E-45 >= VBA.Abs(oCell.value) Or VBA.Abs(oCell.value) >= 3.402823E+38 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Single", " As Double")
Exit For
End If
ElseIf Not bHeaders Then
If 1.401298E-45 >= VBA.Abs(oCell.value) Or VBA.Abs(oCell.value) >= 3.402823E+38 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Single", " As Double")
Exit For
End If
End If
Next oCell
Case Is = 3
aField(lgField) = aField(lgField) & " As Date"
Case Is = 4
aField(lgField) = aField(lgField) & " As String"
On Error Resume Next
Set rgFormulas = rgColumn.SpecialCells(xlCellTypeFormulas).Cells
On Error GoTo 0
If Not rgFormulas Is Nothing Then ' Links to somewhere else
For Each oCell In rgColumn.SpecialCells(xlCellTypeFormulas).Cells
If oCell.Precedents.Count = 1 Then
Set oCellLinked = oCell.Precedents.Item(1)
For Each oName In oCell.Parent.Names
If Not Intersect(oCell.Precedents.Item(1), oName.RefersToRange) Is Nothing Then
If Not oName.Name Like "*_FilterDatabase" Then
If oName.RefersToRange.Columns.Count = 1 Then
bName = True ' --> oName.Name
Exit For
End If
End If
End If
Next oName
End If
If bName Then
Debug.Print oName.Name
Exit For
End If
Next oCell
Set rgFormulas = Nothing
Else
' Find validation list
lgCarrousel = g_Base
ReDim Preserve aCarrousel(g_Base To lgCarrousel)
aCarrousel(lgCarrousel) = rgColumn.Value2(1, 1)
For Each oCell In rgColumn.Cells
If VBA.Abs(lgDeclaration) = 4 Then 'String
If IsBoolean(oCell.Value2) Then
aField(lgField) = VBA.Replace$(aField(lgField), " As String", " As Boolean")
Exit For
ElseIf Not (Not aCarrousel) Then
bCarrousel = False
For lgItem = LBound(aCarrousel) To UBound(aCarrousel)
If Not (bHeaders And oCell.Row = rgHeaders.Row) Then
If aCarrousel(lgItem) = oCell.Value2 Then
bCarrousel = True
Exit For
End If
End If
Next lgItem
Else
bCarrousel = True
End If
If (bHeaders And Not (oCell.Row = rgHeaders.Row)) Or Not bHeaders Then
If Not bCarrousel Then
If Not IsEmpty(oCell.Value2) Then
lgCarrousel = lgCarrousel + 1
ReDim Preserve aCarrousel(g_Base To lgCarrousel)
aCarrousel(lgCarrousel) = oCell.Value2
End If
End If
End If
End If
Next oCell
' Find validation list
If bHeaders Then
If rgColumn.SpecialCells(xlCellTypeConstants).Cells.Count > UBound(aCarrousel) - LBound(aCarrousel) + 1 Then
Debug.Print VBA.Join(aCarrousel(), "/")
End If
Else
If rgColumn.SpecialCells(xlCellTypeConstants).Cells.Count > UBound(aCarrousel) - LBound(aCarrousel) Then
Debug.Print VBA.Join(aCarrousel(), "/")
End If
End If
End If
Case Is = -1: aField(lgField) = aField(lgField) & "() As Long"
Case Is = -2: aField(lgField) = aField(lgField) & "() As Double"
Case Is = -3: aField(lgField) = aField(lgField) & "() As Date"
Case Is = -4: aField(lgField) = aField(lgField) & "() As String"
End Select
End If
Next rgColumn
Stop
Debug.Print VBA.Join(aField(), vbNewLine)
End Sub
Public Function VarDeclaration(ByVal strVarCheck As String) As Long ' String
If IsLong(strVarCheck) Then
VarDeclaration = 1 'Long/Integer/Byte
If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -1 ' Is array
ElseIf IsDouble(strVarCheck) Then
VarDeclaration = 2 'Double/Single
If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -2 ' Is array
ElseIf IsDate(strVarCheck) Then
VarDeclaration = 3 'Date
If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -3 ' Is array
ElseIf IsString(strVarCheck) Then
VarDeclaration = 4 'String
'If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -4 ' Is array
End If
End Function
[/sourcecode]
Is VarType/TypeName replacement functions
So we have the VarType and TypeName functions already implemented in VBA, but, they require variables as the feeder, no considering expressions.
How can we determine if a value is an Integer a Byte or a Long?, a Single or a Double?
Here are some functions that can help to filter the type of variables by their values:
Public Function IsDouble(ByVal value As Variant) As Boolean
If IsNumeric(value) Then IsDouble = Not IsLong(value)
End Function
Public Function IsSingle(ByVal value As Variant) As Boolean
IsSingle = IsDouble(value) And (1.401298E-45 <= VBA.Abs(value) Or VBA.Abs(value) <= 3.402823E+38)
End Function
Public Function IsLong(ByVal value As Variant) As Boolean
If IsNumeric(value) Then IsLong = (VBA.CLng(value) = VBA.Val(value))
End Function
Public Function IsInteger(ByVal value As Variant) As Boolean
IsInteger = (IsLong(value) And VBA.Abs(value) <= 32768)
End Function
Public Function IsByte(ByVal value As Variant) As Boolean
IsByte = (IsLong(value) And VBA.Abs(value) <= 255)
End Function
Public Function IsString(ByVal value As Variant) As Boolean
IsString = (VarType(value) = vbString)
End Function
Public Function IsBoolean(ByVal value As Variant) As Boolean
Dim strTrueLocal As String: strTrueLocal = VBA.CStr(True)
Dim strFalseLocal As String: strFalseLocal = VBA.CStr(False)
IsBoolean = IsString(value) And (VBA.UCase$(value) = "TRUE" _
Or VBA.UCase$(value) = strTrueLocal _
Or VBA.UCase$(value) = "FALSE" _
Or VBA.UCase$(value) = strFalseLocal)
End Function
[/sourcecode]