Posts Tagged ‘VBA’

Evaluate Math functions

October 14th, 2011 admin No comments

I got a question about math functions in excel from a guy

He needed to parse a function like (3^[x1])+([x2]^2)+[x1]+[x3]+3*[x4] into a function
And needed to parse the values for the variables via a range.

I thought I would spread the wealth and share my code with the world….


 'Set reference to: Microsoft Scripting Runtime

Public Function EVAL(sFormula As String, rVarValues As Range)

    Dim tmpDict As Dictionary
    Dim Cell As Range
    Dim i As Long

    Set tmpDict = VariableDictionary(sFormula, "[", "]")

    i = 0

    For Each Cell In rVarValues

        sFormula = Replace(sFormula, tmpDict.Items(i), Cell.Value): i = i + 1

    Next tmpCell

    Set tmpDict = Nothing

    EVAL = EVALUATE(sFormula)

End Function

Private Function VariableDictionary(sString, sStart, sEnd) As Dictionary

    Dim tmpDict As Dictionary
    Dim strTemp As String
    Dim i As Long

    strTemp = ""

    Set tmpDict = New Dictionary

    On Error Resume Next

    For i = 1 To Len(sString)

        If Mid(sString, i, 1) = sStart Then strTemp = ""

        strTemp = strTemp & Mid(sString, i, 1)

        If Mid(sString, i, 1) = sEnd Then tmpDict.Add strTemp, strTemp

    Next i

    On Error GoTo 0

    Set VariableDictionary = tmpDict

    Set tmpDict = Nothing

End Function
Categories: Excel, Formulas, Math, VBA Tags: , , ,

DAX QuerieTables in Excel via VBA

September 16th, 2011 admin No comments

I came upon the this great article DAX Table Queries in Excel from Gobán Saor.
This got me thinking about automating this via VBA.
The first try immediatly led to this macro

Sub Create_QT_Test()

    Dim qtTable As QueryTable
    Dim sConn As String
    Dim sMDX As String
    Dim ws As Worksheet

    sConn = "OLEDB;Provider=MSOLAP.5;" & _
            "Persist Security Info=True;" & _
            "Initial Catalog=Microsoft_SQLServer_AnalysisServices;" & _
            "Data Source=$Embedded$;" & _
            "MDX Compatibility=1;" & _
            "Safety Options=2;" & _
            "MDX Missing Member Mode=Error;" & _
            "Optimize Response=3;" & _
            "Cell Error Mode=TextValue"

    sMDX = "DRILLTHROUGH SELECT FROM [Model] WHERE ([Measures].[Sum of trades])"

    Set ws = ActiveSheet

    Set qtTable = ws.ListObjects.Add(3, sConn, Destination:=Range("B2")).QueryTable

    With qtTable

        .CommandText = sMDX
        .CommandType = xlCmdDefault

    End With

End Sub

I’m going to work on this futher and post better and more code…



Categories: Denali, Excel, MDX, PowerPivot, VBA Tags: , , ,

Shrinking Excel 2010/2007 Files by about 25%

September 9th, 2011 admin No comments

We know the compression technology Excel uses to create and save the files is not optimum.
So after reading a post on BaconBits about it, I thought I would write a macro who creates (small) copies of selected excel files.
The files I produced were all around 25% smaller than the originals.
Worth the effort I would say….

Bare in mind if you save the created files they will grow again….

you can download a sample workbook here Shrink Excel Files

Sub ShrinkExcelFiles()

    Dim Fname
    Dim i As Long
    Dim sFileFolder As String

    Fname = Application.GetOpenFilename(filefilter:="Excel (*.xls*), *.xls*", _
            MultiSelect:=True, Title:="Select the Excel files you want to shrink")  

    If IsArray(Fname) = False Then

       For i = LBound(Fname) To UBound(Fname)

           sUnzipFolder = Left(Fname(i), InStrRev(Fname(i), "\")) & "unzip\"
           ShrinkXlsX Fname(i), sUnzipFolder

       Next i

    End If

End Sub
Sub ShrinkXlsX(sFileName, sTempFolder)

    Dim objApp As Object
    Dim vFileName As Variant
    Dim sFileExtension As String
    Dim i As Long

    sFileExtension = Right(sFileName, Len(sFileName) - InStrRev(sFileName, "."))

    Name sFileName As sFileName & ".zip"

    CreateFolder sTempFolder

    Set oApp = CreateObject("Shell.Application")

    For Each ItemInZip In oApp.Namespace(sFileName & ".zip").items

        oApp.Namespace(sTempFolder).CopyHere (ItemInZip)


    Open sFileName & "" For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1

    i = 1

    For Each ItemInFolder In oApp.Namespace(sTempFolder).items

        oApp.Namespace(sFileName & "").CopyHere (ItemInFolder)

        Do Until oApp.Namespace(sFileName & "").items.Count = i

            Application.Wait (Now + TimeValue("0:00:01"))


        i = i + 1


    Name sFileName & "" As sFileName & "_Small." & sFileExtension
    Name sFileName & ".zip" As sFileName

    DeleteFolder sTempFolder

End Sub
Sub DeleteFolder(MyPath)

    Dim FSO As Object

    Set FSO = CreateObject("scripting.filesystemobject")

    If Right(MyPath, 1) = "\" Then MyPath = Left(MyPath, Len(MyPath) - 1)

    If FSO.FolderExists(MyPath) = False Then Exit Sub

    FSO.DeleteFolder MyPath

End Sub

Sub CreateFolder(MyPath)

    Dim FSO As Object

    Set FSO = CreateObject("scripting.filesystemobject")

    If Right(MyPath, 1) = "\" Then MyPath = Left(MyPath, Len(MyPath) - 1)

    If FSO.FolderExists(MyPath) = True Then DeleteFolder MyPath

    FSO.CreateFolder MyPath

End Sub
Categories: Excel, VBA Tags: ,

Unprotect Sheet in Excel

August 30th, 2011 admin No comments

I’m back from my holiday in the land of no internet and cellphone coverage.
The up side was ( or one of the up sides ) I had time finally post this piece of code to unprotect a sheet with a forgotten password.
The nice thing is you can protect the sheet with the found password and the old password still works …. lol

Sub PasswordBreaker()

   Dim i0 As Integer, i1 As Integer, i2 As Integer, i3 As Integer
   Dim i4 As Integer, i5 As Integer, i6 As Integer, i7 As Integer
   Dim i8 As Integer, i9 As Integer, m1 As Integer, m2 As Integer

   Dim sPassword As String

   On Error Resume Next

   For i0 = 65 To 66: For i1 = 65 To 66: For i2 = 65 To 66: For i3 = 65 To 66
   For i4 = 65 To 66: For i5 = 65 To 66: For i6 = 65 To 66: For i7 = 65 To 66
   For i8 = 65 To 66: For i9 = 65 To 66: For m1 = 65 To 66: For m2 = 32 To 126

   sPassword = ""
   sPassword = sPassword & Chr(i0) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5)
   sPassword = sPassword & Chr(i6) & Chr(i7) & Chr(i8) & Chr(i9) & Chr(m1) & Chr(m2)

   ActiveSheet.Unprotect sPassword

   Application.StatusBar = False

   If ActiveSheet.ProtectContents = False Then

      MsgBox "Password used to unprotect this sheet is: " & sPassword

      Exit Sub

   End If

   Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next

End Sub


Categories: Excel, VBA Tags: ,

Strange VBA Code

July 15th, 2011 admin No comments


I recently came upon some vba code in a workbook from the Hong Kong branch.
There were a lot of construction in there like:

Range(ThisWorkbook.Names("RANGE_NAME").RefersTo).Cells(1, 1).Value

Does anybody know why someone would code like this….?


Categories: Excel, VBA Tags: ,

Bottom left part of the UsedRange

June 6th, 2011 admin No comments

The csv file I import in my previous post contains two rows of informational data followed by a blank row followed by the real data. I needed to determine this range to loop though.
I decided to make a function and this is what I cam up with.

Feel free to shoot at it….


Function DataRange(tmpWorkSheet As Worksheet) As Range

    Dim rTemp As Range

    Set rTemp = tmpWorkSheet.UsedRange.Columns(1)
    Set rTemp = rTemp.Cells(rTemp.Rows.Count, 1)
    Set rTemp = rTemp.CurrentRegion

    Set DataRange = rTemp

End Function
Categories: CSV, Excel, VBA Tags: , ,

Scheduled Import a online csv file into Workbook

May 27th, 2011 admin No comments

For a client I needed a solution for a scheduled import of a online csv file into a workbook. There are many ways to download files from the internet but it needed to be in excel as there were a whole lot of macro’s allready in place to transform and process the downloaded data. They had a machine running at all time ( not a server ) to be used.
So this is the code I came up with. It runs every day after it is started by running the StartSchedule Procedure

Option Explicit

Public tTime As Date

Sub StartSchedule()

    tTime = Now()

End Sub

Sub Schedule()

    tTime = tTime + TimeSerial(23, 59, 59)
    Application.OnTime tTime, "ImportCSV"

End Sub

Sub ImportCSV()

    Dim tmpSheet As Worksheet

    Set tmpSheet = ThisWorkbook.Sheets.Add(,,, "")

    tmpSheet.Name = tmpSheet.Name & " " & Format(Now(), "yyyy-mm-dd hh-mm-ss")


End Sub
Categories: CSV, Excel, VBA Tags: , ,

VBA function for returning Column names, type as a dictionary

May 18th, 2011 admin No comments

February 16th, 2010

I needed the column names of a sql server 2008 table.
So I wrote a function who would return a dictionary with the column names as the key and the type as the item.

‘Set Reference to Microsoft Scripting Runtime
‘Set Reference to Microsoft ActiveX Data Objects 2.7 Library

Function ColumnNames(sConnection As String, sTable As String) As Dictionary

   Dim cConnection As ADODB.Connection
   Dim rsRecordset As ADODB.Recordset
   Dim sSQL As String
   Dim dColumnNames As Dictionary

   sSQL = sSQL & “SELECT AS column_name, AS datatype ”
   sSQL = sSQL & “FROM sysobjects so ”
   sSQL = sSQL & “JOIN syscolumns sc ON = ”
   sSQL = sSQL & “JOIN systypes st ON sc.xtype = st.xtype ”
   sSQL = sSQL & “WHERE so.xtype = ‘U’ ”
   sSQL = sSQL & “AND <> ’sysname’ ”
   sSQL = sSQL & “AND = ‘” & sTable & “‘”

   Set dColumnNames = New Dictionary

   Set cConnection = New ADODB.Connection

   cConnection.Open sConnection
   Set rsRecordset = New ADODB.Recordset
   Set rsRecordset.ActiveConnection = cConnection

   rsRecordset.Open sSQL

   Do While Not rsRecordset.EOF And Not rsRecordset.BOF

      dColumnNames.Add rsRecordset.Fields(0).Value, rsRecordset.Fields(1).Value


   Set rsRecordset = Nothing
   Set cConnection = Nothing

   Set ColumnNames = dColumnNames

End Function

Source file: M_ColumnNames

Categories: Excel, VBA Tags: ,