VBA Code Samples

' Returns the rightmost characters of a string upto but not including the rightmost '\'

' e.g. 'c:\winnt\win.ini' returns 'win.ini'

Public Function GetFilenameFromPath(ByVal strPath As String) As String   

    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then

        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)

    End If

End Function

Sub load_withADO(filePath As String, toSheet As Worksheet)

    Dim qt As QueryTable

    'toSheet.Activate

    'toSheet.Range("A1").Select

    Set qt = toSheet.QueryTables.Add( _

        Connection:="TEXT;" & filePath, Destination:=toSheet.Range("A1"))

    With qt

        .TextFilePlatform = 437

        .TextFileStartRow = 1

        .TextFileParseType = xlDelimited

        .TextFileCommaDelimiter = True

        .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2)

    End With

    qt.Refresh BackgroundQuery:=False

    qt.Delete

End Sub

' Vlookup function with at most 5 conditions into the columns.

' return the value on lookupCol

' input: put colX to 0 if you don't want to use that condition.

' output:

'   value if row is unique

'   "MISSING" if row is not found

'   "DUBIOUS" if multiple rows are found

' NOTE: the range must have a header for filtering.

' ALSO: ignoreNil = True will ignore any valX = "" , even you try to filter based on it.

Public Function VLookupWithMultiConditions( _

    lookupSheet As Worksheet, lookupCol As Integer, ignoreNil As Boolean, _

    col1 As Integer, val1 As String, col2 As Integer, val2 As String, _

    col3 As Integer, val3 As String, col4 As Integer, val4 As String, _

    col5 As Integer, val5 As String) As String

    ' filter

    turnOffFilter lookupSheet

    If ignoreNil = True Then

        With lookupSheet.UsedRange

            If col1 <> 0 And val1 <> "" Then .AutoFilter Field:=col1, Criteria1:=val1

            If col2 <> 0 And val2 <> "" Then .AutoFilter Field:=col2, Criteria1:=val2

            If col3 <> 0 And val3 <> "" Then .AutoFilter Field:=col3, Criteria1:=val3

            If col4 <> 0 And val4 <> "" Then .AutoFilter Field:=col4, Criteria1:=val4

            If col5 <> 0 And val5 <> "" Then .AutoFilter Field:=col5, Criteria1:=val5

        End With

    Else

        With lookupSheet.UsedRange

            If col1 <> 0 Then .AutoFilter Field:=col1, Criteria1:=val1

            If col2 <> 0 Then .AutoFilter Field:=col2, Criteria1:=val2

            If col3 <> 0 Then .AutoFilter Field:=col3, Criteria1:=val3

            If col4 <> 0 Then .AutoFilter Field:=col4, Criteria1:=val4

            If col5 <> 0 Then .AutoFilter Field:=col5, Criteria1:=val5

        End With

    End If

    ' find the answer

    Dim rng As Range

    With lookupSheet.UsedRange

        On Error Resume Next

        Set rng = .Range(.Cells(2, lookupCol), .Cells(.Rows.Count, lookupCol)).SpecialCells(xlCellTypeVisible)

        On Error GoTo 0

    End With

    ' return

    If rng Is Nothing Then '0

        VLookupWithMultiConditions = "MISSING"

    ElseIf InStr(rng.Address, ",") > 0 Then

        VLookupWithMultiConditions = "DUBIOUS"

'    ElseIf Split(Replace(rng.Address, ":", ""), "$")(2) <> Split(Replace(rng.Address, ":", ""), "$")(4) Then

'        VLookupWithMultiConditions = "DUBIOUS"

    Else

        VLookupWithMultiConditions = Trim(rng(1).Value)

    End If

    ' off the filters

    turnOffFilter lookupSheet

End Function

' turn off the filter

Public Sub turnOffFilter(aSheet As Worksheet)

    If Not aSheet.AutoFilter Is Nothing Then

        aSheet.UsedRange.AutoFilter

    End If

End Sub

' sort array

Sub BubbleSort(MyArray() As String)

    Dim First           As Integer

    Dim Last            As Integer

    Dim i               As Integer

    Dim j               As Integer

    Dim Temp            As String

    Dim List            As String

    First = LBound(MyArray)

    Last = UBound(MyArray)

    For i = First To Last - 1

        For j = i + 1 To Last

            If MyArray(i) > MyArray(j) Then

                Temp = MyArray(j)

                MyArray(j) = MyArray(i)

                MyArray(i) = Temp

            End If

        Next j

    Next i

    'for debugging

    'For i = First To UBound(MyArray)

    '    List = List & vbCrLf & MyArray(i)

    'Next

    'MsgBox List

End Sub

' get open balance

Public Sub getBalance(ByVal sdate As String)

    ' init public var

    Call setVar

    ' get string

    ' query

    Dim mysql As String

    mysql = "select balance_date, ibfas_acc_id, currency, ibfas_entity as seg4_code, " & _

            "ibfas_natural_code as seg1_code, ibfas_book as seg2_code, ibfas_client_id, " & _

            "close_bal, syn_acc_id, syn_ledger, " & _

            "case when close_bal < 0 then ""C"" else ""D"" end credit_debit, " & _

            "abs(close_bal) " & _

            "from rpt.." & fromTable & " where balance_date = " & "'" & sdate & "' " & _

            "order by syn_ledger, currency"

    ' connection

    Dim cn As ADODB.Connection

    Set cn = New ADODB.Connection

    cn.Open "DRIVER={SYBASE ASE ODBC Driver};" & _

            "NA=" & ip & "," & port & ";" & _

            "DB=" & db & ";" & _

            "UID=" & uid & ";" & _

            "PWD=" & pwd

    ' record set

    Dim rs As ADODB.Recordset

    Set rs = New ADODB.Recordset

    With rs

        Set .ActiveConnection = cn

        .CursorLocation = adUseClient

        .Source = mysql 'Pass your SQL

        .Open adOpenKeyset, adLockOptimistic, -1

    End With

    ' deccide the number of balance sheet needed (incase > 65535 rows in a set)

    numBalSheet = Int(rs.RecordCount / 65500) + 1

    ' fill sheet by sheet

    Dim i As Integer

    For i = 1 To numBalSheet

        ' new sheet

        Set balSheet = mainBook.Sheets.Add(After:=mainSheet)

        balSheet.Name = "Balance_" & i

        mainSheet.Activate

        ' result sheet.

        With balSheet

            .UsedRange.ClearContents

            .Cells.NumberFormat = "@" 'format to strings.

            .Cells(1, 1) = "Closeing Balance Date"

            ' more header codes

            .Cells(2, 1).CopyFromRecordset rs, 65500 'maximum this rows

        End With

    Next

    ' release pointers.

    rs.Close

    Set rs = Nothing

    cn.Close

    Set cn = Nothing

End Sub

' get syn adjustment for the date

Public Sub getSynAdjustment(ByVal sdate As String)

    Call setVar

    'query

    Dim mysql As String

    mysql = "SELECT 'SYN', " & _

            "entry_date, posting_date, ledger, account_key, currency, crdr, amount, " & _

            "source_reference, " & _

            "group_1, group_2, group_3, group_4, group_5 " & _

            "FROM synrpt.dailyposting_rpt " & _

            "WHERE entry_date = " & "'" & sdate & "' " & _

            "AND source_reference like 'ADJ%' " & _

            "Order by ledger, account_key, currency"

    ' connection

    Dim cn As ADODB.Connection

    Set cn = New ADODB.Connection

    cn.Open "Driver={Microsoft ODBC for Oracle};" & _

            "CONNECTSTRING=(DESCRIPTION=" & _

            "(ADDRESS=(PROTOCOL=TCP)" & _

            "(HOST = " & oraip & ")(PORT = " & oraport & "))" & _

            "(CONNECT_DATA=(SID=" & orasid & "))); uid=" & orauid & ";pwd=" & orapwd & ";"

    ' record set

    Dim rs As ADODB.Recordset

    Set rs = New ADODB.Recordset

    With rs

        Set .ActiveConnection = cn

        .CursorLocation = adUseClient

        .Source = mysql 'Pass your SQL

        .Open adOpenKeyset, adLockOptimistic, -1

    End With

    ' release pointers.

    rs.Close

    Set rs = Nothing

    cn.Close

    Set cn = Nothing

End Sub

Public Sub SearchClick(ByVal xlsName As String, ByVal workDir As String, ByRef dstSheet As Worksheet)

    Dim xlsPath As String

    xlsPath = workDir & "\" & xlsName

    'turn off screen updateing

    Application.ScreenUpdating = False

    ' query

    Dim mysql As String

    mysql = "select * FROM [Sheet1$] WHERE TRADEREF IS NOT  NULL"

    ' connection

    Dim cn As ADODB.Connection

    Set cn = New ADODB.Connection

    cn.Open "Driver={Microsoft Excel Driver (*.xls)};" & _

            "DBQ=" & xlsPath & "; ReadOnly=True"

    ' record set

    Dim rs As ADODB.Recordset

    Set rs = New ADODB.Recordset

    With rs

        Set .ActiveConnection = cn

        .Source = mysql 'Pass your SQL

        .Open

    End With

    ' fill sheet by sheet

    With dstSheet

        .UsedRange.ClearContents

        .Cells.NumberFormat = "@" 'format to strings.

        .Cells(1, 1).CopyFromRecordset rs, 65500

    End With

    ' release pointers.

    rs.Close

    Set rs = Nothing

    cn.Close

    Set cn = Nothing

    'turn screen updateing back on

    Application.ScreenUpdating = True

End Sub

' check if str is in Array

Public Function isInArray(ByVal str As String, ByRef arr() As String) As Boolean

    Dim longStr As String

    longStr = "|" & Join(arr, "|") & "|"

'    Debug.Print longStr

    If (InStr(longStr, "|" & str & "|")) Then

        isInArray = True

    Else

        isInArray = False

    End If

End Function

' number to letter

Public Function columnLetter(columnNumber As Integer) As String

    If columnNumber > 26 Then

      ' 1st character:  Subtract 1 to map the characters to 0-25,

      '                 but you don't have to remap back to 1-26

      '                 after the 'Int' operation since columns

      '                 1-26 have no prefix letter

      ' 2nd character:  Subtract 1 to map the characters to 0-25,

      '                 but then must remap back to 1-26 after

      '                 the 'Mod' operation by adding 1 back in

      '                 (included in the '65')

      columnLetter = Chr(Int((columnNumber - 1) / 26) + 64) & _

                     Chr(((columnNumber - 1) Mod 26) + 65)

    Else

      ' Columns A-Z

      columnLetter = Chr(columnNumber + 64)

    End If

End Function

' letter to number

Public Function columnNumber(ByVal columnLetter As String) As Integer

    Dim tempChar As String

    Dim numString  As String

    Dim tempNum As Integer

    Dim numArray() As Integer

    Dim i As Integer

    Dim highPower As Integer

    tempChar = ""

    tempNum = 0

    ' *****************************************************

    columnLetter = UCase(columnLetter)

    For i = 1 To Len(columnLetter)

        numString = ""

        tempChar = Mid(columnLetter, i, 1)

        ReDim Preserve numArray(i)

        numArray(i) = Asc(tempChar) - 64

    Next

    ' ********* Our Most Significant Digits Occur to the Left *****************

    highPower = UBound(numArray()) - 1

    ' ******** Convert the Number Array using Powers of 26 *****************

    For i = 1 To UBound(numArray())

        tempNum = tempNum + (numArray(i) * (26 ^ highPower))

        highPower = highPower - 1

    Next

    ' *************************************************************

    columnNumber = tempNum

End Function

' delete hidden rows

Public Sub deleteHiddenRows(asheet As Worksheet)

    Dim i As Long

    With asheet

        For i = .UsedRange.Rows.Count To 2 Step -1 'leave header alone

            If .Cells(i, 1).EntireRow.Hidden = True Then

                .Cells(i, 1).EntireRow.Delete

            End If

        Next i

    End With

End Sub

Public Function reopenWorkbook(inputFolder, xlsName) As Workbook

    ' close existing workbook if there is

    On Error Resume Next

    If Not Workbooks(xlsName) Is Nothing Then

        Application.DisplayAlerts = False

        Workbooks(xlsName).Close

        Application.DisplayAlerts = True

    End If

    On Error GoTo 0

    ' re-open from the path

    Set reopenWorkbook = Application.Workbooks.Open(inputFolder & "\" & xlsName)

End Function

' create a new book, and save the asheet as the first sheet in the workbook.

' delete other worksheets.

Public Function saveSheetToBook(aSheet As Worksheet, folder As String, name As String) As Workbook

    ' close existing workbook if there is

    On Error Resume Next

    If Not Workbooks(name) Is Nothing Then

        Application.DisplayAlerts = False

        Workbooks(name).Close

        Application.DisplayAlerts = True

    End If

    On Error GoTo 0

    Set saveSheetToBook = Workbooks.Add

    With saveSheetToBook

        .Title = name

        .SaveAs Filename:=folder & "\" & name

        .Worksheets(1).name = name

        Application.DisplayAlerts = False

        Do While .Worksheets.Count > 1

            .Worksheets(2).Delete

        Loop

        Application.DisplayAlerts = True

    End With

    aSheet.UsedRange.Copy saveSheetToBook.Worksheets(name).Cells(1, 1)

End Function

'Purpose   :    Makes a directory/path (inc. any the required parent directories)

'Inputs    :    sPath               The directory to create

'Outputs   :    Returns True if succeeded in creating directory

Public Function MakeDir(ByVal sPath As String) As Boolean

    Dim asDirs() As String, sDir As String

    Dim lStartPos As Long, lThisDir As Long, lNumDirs As Long

    If DirExists(sPath) = False Then

        'Ignore errors when creating paths that already exist

        'or UNC paths, then check if the path exists at the end

        On Error Resume Next

        If Right$(sPath, 1) = "\" Then

            sPath = Left$(sPath, Len(sPath) - 1)

        End If

        asDirs = Split(sPath, "\")

        lNumDirs = UBound(asDirs)

        sDir = ""

        For lThisDir = 0 To lNumDirs

            sDir = sDir & asDirs(lThisDir) & "\"

            If Len(asDirs(lThisDir)) Then

                If DirExists(sDir) = False Then

                    MkDir sDir

                End If

            End If

        Next

        'Check if the directory exists

        MakeDir = DirExists(sPath)

    Else

        MakeDir = True

    End If

End Function

'Purpose   :    Check if a Path Exists

'Inputs    :    sPath           The path to check

'Outputs   :    Returns True if the path exists, False if it doesn't

Public Function DirExists(ByVal sPath As String) As Boolean

    If sPath <> ".." And sPath <> "." And sPath <> "\" And Len(sPath) Then

        If Right$(sPath, 1) <> "\" Then

            sPath = sPath & "\"

        End If

        On Error Resume Next

        DirExists = (GetAttr(sPath) And vbDirectory) > 0

        On Error GoTo 0

    End If

End Function

' move file from fpath to dpath

' make sure the fpath and dpath folder both exists

Public Sub MoveFile(fpath As String, dpath As String)

    Dim fso As Variant

    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.fileExists(fpath) Then

        Application.DisplayAlerts = False

        If fso.fileExists(dpath) Then

            Kill dpath

        End If

        fso.MoveFile fpath, dpath

        Application.DisplayAlerts = True

    End If

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim TargetGoal As Variant

    If Not Application.Intersect(Target, Range("e3:e11,e13:e29,g3:g3,g5:g8,g12:g29,g31:g31")) Is Nothing Then

        Target.Interior.Color = vbGreen

        Target.Offset(0, 1) = Now

        Application.SendKeys "{Esc}"

        Target = "Complete"

    End If

End Sub

Option Explicit  Sub MakeMultipleXLSfromWB()   'Split worksheets in current workbook into   ' many separate workbooks  D.McRitchie, 2004-06-12   'Close each module  AND the VBE before running to save time   ' provides a means of seeing how big sheets really are   'Hyperlinks and formulas pointing to other worksheets within   ' the original workbook will usually be unuseable in the new workbooks.     Dim CurWkbook As Workbook     Dim wkSheet As Worksheet     Dim newWkbook As Workbook     Dim wkSheetName As String     Dim shtcnt(3) As Long     Dim xpathname As String, dtimestamp As String     dtimestamp = Format(Now, "yyyymmdd_hhmmss")     xpathname = "c:\temp\D" & dtimestamp & "\"     MkDir xpathname     Set CurWkbook = Application.ActiveWorkbook      shtcnt(2) = ActiveWorkbook.Sheets.Count     Application.ScreenUpdating = False     Application.Calculation = xlCalculationManual     For Each wkSheet In CurWkbook.Worksheets       shtcnt(1) = shtcnt(1) + 1       Application.StatusBar = shtcnt(1) & "/" & shtcnt(2) & _           "  " & wkSheet.Name       wkSheetName = Trim(wkSheet.Name)       If wkSheetName = Left(Application.ActiveWorkbook.Name, _          Len(Application.ActiveWorkbook.Name) - 4) Then _          wkSheetName = wkSheetName & "_D" & dtimestamp       Workbooks.Add       ActiveWorkbook.SaveAs _          filename:=xpathname & wkSheetName & ".xls", _          FileFormat:=xlNormal, Password:="", _          WriteResPassword:="", CreateBackup:=False, _          ReadOnlyRecommended:=False       Set newWkbook = ActiveWorkbook              Application.DisplayAlerts = False       newWkbook.Worksheets("sheet1").Delete       On Error Resume Next       newWkbook.Worksheets(wkSheet.Name).Delete       On Error GoTo 0       Application.DisplayAlerts = True         CurWkbook.Worksheets(wkSheet.Name).Copy Before:=newWkbook.Sheets(1)       'no duplicate sheet1 because they begin with "a"       ActiveWorkbook.Save       ActiveWorkbook.Close     Next wkSheet     Application.StatusBar = False      'return control to Excel     Application.Calculation = xlCalculationAutomatic     Application.ScreenUpdating = True End Sub

' 1 date/time, 2, higher bound, 3, lower bound

' Save the plot into a worksheet, with a name.

' If plot with same name exist, replace it.

' Data columns should be stored in a invisible worksheet under the same plotname.

Sub CreateBeltPlot(toSheetName As String, chartName As String, sourceRange As Range)

    Dim i As Integer, rowCount As Long

    Dim toSheet As Worksheet, chartSheet As Worksheet

    ' 1) confirm toSheet exists, otherwise, create

    On Error Resume Next

    If Worksheets(toSheetName) Is Nothing Then

        Application.DisplayAlerts = False

        Worksheets.Add(after:=Worksheets(1)).Name = toSheetName

        Application.DisplayAlerts = True

    End If

    On Error GoTo 0

    Set toSheet = Worksheets(toSheetName)

    ' 2) confirm worksheet with the same chartName does not exist, otherwise, delete all data

    On Error Resume Next

    If Worksheets(chartName) Is Nothing Then

        Application.DisplayAlerts = False

        Worksheets.Add(after:=Worksheets(1)).Name = chartName

        Application.DisplayAlerts = True

    End If

    On Error GoTo 0

    Set chartSheet = Worksheets(chartName)

    chartSheet.Rows.Delete

    ' 3) confirm chartName is new, otherwise remove from the old sheet

    For i = 1 To toSheet.Shapes.Count

        If toSheet.Shapes.Item(i).Name = chartName Then

            toSheet.Shapes.Item(i).Delete

        End If

    Next

    ' 4) copy data to new chart worksheet

    sourceRange.Copy chartSheet.Range("A1")

    rowCount = chartSheet.UsedRange.Rows.Count

    chartSheet.Range("D1") = "Delta"

    For i = 2 To rowCount

        chartSheet.Range("D" & i) = chartSheet.Range("C" & i) - chartSheet.Range("B" & i)

    Next

    ' 5) --------plot----------------

    Dim objShape As Shape

    Dim myChart As Variant

    Dim myHigh As Variant, myLow As Variant, myDelta As Variant, myDupHigh As Variant

    Set objShape = toSheet.Shapes.AddChart(XlChartType.xlLine)

    objShape.Name = chartName

    'objShape.ScaleWidth 1.4333333333, msoFalse, msoScaleFromTopLeft

    'objShape.ScaleHeight 1.3281251823, msoFalse, msoScaleFromTopLeft

    If Not objShape.HasChart Then

        Exit Sub

    End If

    Set myChart = objShape.Chart

    ' data from higher and lower

    myChart.SetSourceData Source:=chartSheet.Range("A2:C" & rowCount)

    myChart.Axes(xlCategory).TickLabels.NumberFormat = "mmm-yy"

    myChart.Axes(xlCategory).MajorUnit = 2

    myChart.Axes(xlCategory).MajorUnit = 10

    ' series 1, high

    ' series 2, low

    Set myHigh = myChart.SeriesCollection(1)

    Set myLow = myChart.SeriesCollection(2)

    ' series 3, dup higher bound

    Set myDupHigh = myChart.SeriesCollection.NewSeries

    myDupHigh.Values = "=" & chartSheet.Name & "!$B$2:$B$" & rowCount

    ' series 4, delta of line 2 and line 1line

    Set myDelta = myChart.SeriesCollection.NewSeries

    myDelta.Values = "=" & chartSheet.Name & "!$D$2:$D$" & rowCount

    ' style of dup high

    myDupHigh.ChartType = xlAreaStacked

    myDupHigh.Format.Fill.Visible = msoFalse

    ' style of delta

    myDelta.ChartType = xlAreaStacked

    With myDelta.Format.Fill

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorAccent1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = 0.6000000238

        .Transparency = 0

    End With

    ' higher bound

    With myHigh.Format.Line

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorAccent1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = 0.6000000238

    End With

    ' lower bound

    With myLow.Format.Line

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorAccent1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = 0.6000000238

    End With

    With objShape.Chart

        .Legend.Delete    ' legends

        .SetElement (msoElementChartTitleAboveChart)     ' title

        .ChartTitle.Text = chartName

    End With

    With objShape

        'position

        .Top = Range("A1").Top

        .Left = Range("A1").Left

        .Width = Range("A1:H1").Width

        .Height = Range("A1:A12").Height

    End With

End Sub

Sub test()

    CreateBeltPlot "charts", "chart1", Range("Sheet1!$B$4:$B$39,Sheet1!$E$4:$F$39")

End Sub