VBA -

_vba_excel_utils.readme

---------------------------------------
VBA Excel Utilties
---------------------------------------

Excel is a great tool for quick-n-dirty analysis.
But, staring at raw data in it can be a pain. So,
I created misc utilities to pull in data from SQL
servers, format data, border-split rows to group
similar data together, dupe-check data (made this
before MS got smart and built a version into later
Excel versions), etc.

The SQL pull uses ADODB lib, so you'll need to hook
into that in your Excel VBA environment you use this
from.

vba_excel_utils.bas

'--------------------------------------------------
' Misc Utilities for Excel
'--------------------------------------------------
' Excel is a great tool for quick-n-dirty data analysis,
' but lacking sometimes. So, I created some utils help
' me format data to analyze easier, pull data from other
' sources, create SQL's etc. Had most of these assigned
' to custom buttons on toolbar, making them easy to
' fire off.
'--------------------------------------------------

Option Explicit

'--------------------------------------------------
' Public Constants & Variables
'--------------------------------------------------

Public ErrorMsg As String   'make this public so other procedures can use / see it in other modules


'--------------------------------------------------
Public Sub Error_Detail()
'
' VBA error messages are lacking. So, created an
' output that formats them a bit nicer, and also
' dumps them out as string for user feedback if needed.
'--------------------------------------------------

Dim s As String

    With Err
        Debug.Print String(50, "-")             'add a nice border to separate error msg from old debug window content
        Debug.Print .Source                     'dump out the important stuff to the debug window (mainly for me)
        Debug.Print .Number
        Debug.Print .Description
        
        ErrorMsg = .Source & vbCrLf             'generate user feedback string
        ErrorMsg = ErrorMsg & .Number & vbCrLf
        ErrorMsg = ErrorMsg & .Description
    End With

    Reset_Mouse_Status              'if an error blew something up, reset user control of excel

End Sub


'--------------------------------------------------
Sub Reset_Mouse_Status()
'
' some funcs set Excel environment up to 
' show user that things are processing.
' this resets mouse/statusbar/screenupdating,
' called from sub/func or manual reset
'--------------------------------------------------

    Application.Cursor = xlDefault
    Application.StatusBar = False
    Application.ScreenUpdating = True

End Sub


'--------------------------------------------------
Sub Convert_Text_To_Number()                'convert text-formated numbers to actual numbers
'
' Excel has an annoying habit to take some numbers
' and paste them in as text instead of numbers.
' This func goes through your highlighted
' selection, and converts text to numbers if
' possible.
'--------------------------------------------------

Dim c As Variant    'generic "cell" object to iterate through "cells" group

On Error Resume Next                        'error occurs if we try to re-format actual text, or use sub w/o workbook open

    For Each c In Selection.Cells           'go through each cell in selection
'        c.Value = Val(c.Value)              'could use this to convert, but makes text = 0, so I use mine below
        
        ' this won't convert text to 0...it'll leave it alone,
        ' and only convert numbers. It does this by causing an
        ' error when converting text, which the sub catches and
        ' skips via On Error Resume Next

        With c
            If .Value <> "" Then            'if a cell's not blank
                .Value = CDbl(.Value)       'make it's value a double/number
            End If
        End With 'c
    
    Next c

End Sub


'--------------------------------------------------
Sub Border_Split()
' borders / segments out rows by comparing values
' in a column you give it. Makes it easier to group
' things in a sheet to eyeball. EG: you sorted a
' a bunch of customer records in excel by their
' cust_id's, but it's hard to see where each one
' starts and ends. You just select the 'cust_id'
' column, and fire off the Border_Split() and it
' will create a line border between each unique
' cust_id row.
'--------------------------------------------------

Dim c As Integer    'what column # to base segregation on
Dim i As Long       'generic row iterator (large enough to cover all 65k rows if need be)

On Error GoTo ERROR_HANDLER                 'error is caused when no workbook/worksheet is open

    Debug.Print ActiveWindow.Visible        'returns an error if no activewindow is visible, which makes button clicks get ignored

    c = Selection.Column

    With ActiveSheet.Range("A1").Offset(0, c - 1) 'subtract 1 from col # since we're doing an offset from A1 (IE: col 1 already counted)
        For i = 1 To .CurrentRegion.End(xlDown).Row
            If .Offset(i, 0).Value <> .Offset(i + 1, 0) Then
                .Offset(i, 0).EntireRow.Borders(xlEdgeBottom).LineStyle = xlContinuous
            End If
        Next i
    End With 'range

END_SUB:

    Exit Sub

ERROR_HANDLER:

    Error_Detail                            'if an error occurs, dump out an error report
    GoTo END_SUB                            'go to end procedure

End Sub


'--------------------------------------------------
Sub Format_Data()
' Row 1 should be header row
' Row 2+ should be data rows
'     switches off text wrapping
'     changes date col's to m/d/yy format
'     auto-formats end result to make it look pretty
'--------------------------------------------------

Dim i As Byte           '256 col max
Dim t As Single

On Error GoTo ERROR_HANDLER                                 'if an error occurs, exit sub (eg: if they click button w/o worksheet open)

    Debug.Print ActiveWindow.Visible                        'returns an error if no activewindow is visible, which makes button clicks get ignored

'    t = Timer                                              'snag start time

    With ActiveSheet.Range("A2")                            'A1 should be header row, A2 should be start of data
    
        With .CurrentRegion                                 'lasso currentregion A1's connected to (IE: data set)
            .WrapText = False                               'turn off wrap-text (I hate when rows aren't evenly spaced)

            For i = 1 To .Columns.Count                     'for each column, try to re-format date fields as "m/d/yy"
                With .Columns(i).Rows(2)
                    If .NumberFormat Like "m*/d*" _
                    Or .NumberFormat Like "h*:*" _
                    Or .NumberFormat Like "m*:*" Then
                        .EntireColumn.NumberFormat = "m/d/yy"
                    End If
                End With
            Next i
    
            .AutoFormat                                     'autoformat the results to look pretty
        End With 'CurrentRegion

        .Select                                             'select "A2" to clean up

    End With 'range
        
    ActiveWindow.FreezePanes = True                         'freeze panes on cell selected so header row stays put while scrolling

'    Debug.Print Timer - t                                  'debug - time how long it took (exact time)
'    Debug.Print Format(Timer - t, "0.00")                  'debug - time how long it took (nearest 100th sec)

END_SUB:

    Exit Sub

ERROR_HANDLER:

    Error_Detail                                'if an error occurs, dump out an error report
    GoTo END_SUB                                'go to end procedure

End Sub


'--------------------------------------------------
Public Sub Format_Page()
' Can be a pain trying to format page setup for a
' report or datasheet to print. So, this func
' formats page setup for all sheets selected;
' anticipates how it should be setup while doing so,
' so will anticipate legal vs. letter page setup,
' landscape vs. portrait.. trying to fit data to
' printable page format as best it can.
'--------------------------------------------------

Dim ws As Excel.Worksheet
Dim ps As PageSetup
Dim pt As Byte          'pages tall = 1 or 255 (which makes it however tall it needs to be)
Dim pw As Byte          '1 = xlPortrait, 2 = xlLandscape
Dim t As Single
Dim m25 As Double       'page margin var, contains the InchesToPoints conversion of .25"
Dim m50 As Double       'page margin var, contains the InchesToPoints conversion of .50"

On Error GoTo ERROR_HANDLER

    Debug.Print ActiveWindow.Visible            'returns an error if no activewindow is visible, which makes button clicks get ignored

'    t = Timer                                   'snag start time
    With Application
        .ScreenUpdating = False                 'turn off screen updating / refresh to process a bit faster
        m25 = .InchesToPoints(0.25)             'snag .25" margin conversion to points
        m50 = .InchesToPoints(0.5)              'snag .50" margin, too
    End With 'Application
    
    For Each ws In ActiveWindow.SelectedSheets  'do page setup for each sheet currently selected
    
        pt = 1                                  'default pages tall to 1 (single-page)
        pw = 1                                  'default page orientation to 1 (xlPortrait)
    
        With ws
            Set ps = .PageSetup                 'snag current sheet's pagesetup object
            ps.Zoom = 100                       'set to 100% zoom page formatting, to reset page-breaks and re-setup if needed
            If .HPageBreaks.Count > 0 Then pt = 255 'if 1+ Horizontal page breaks, make pages tall = 255 (multi-page)
            If .VPageBreaks.Count > 0 Then pw = 2 'if 1+ Vertical page breaks, make page orientation = 2 (xlLandscape)
        End With 'ws
    
        With ps                                 'with prep-work done, execute actual page setup
            .LeftHeader = "&A"                  'left header = file name
            .RightHeader = "&F"                 'right header = datasheet's name
            .LeftFooter = "Print Time: &T, &D"  'left footer = Print Time
            .CenterFooter = "Page &P of &N"     'center footer = "Page # of #"
            .LeftMargin = m25                   'reduce margins to fit more on pg
            .RightMargin = m25
            .TopMargin = m50
            .BottomMargin = m50
            .HeaderMargin = m25
            .FooterMargin = m25
            .CenterHorizontally = True          'I like it centered
            .Zoom = False                       'turn off "fit to %"...we want to use "fit to X by Y pages tall/wide"
            .Orientation = pw                   'xlPortrait (1) or xlLandscape (2) depending on V page breaks determined earlier
            .PaperSize = xlPaperLetter          'xlPaperLetter or xlPaperLegal
            .PrintGridlines = True              'prints faint gridlines for easy viewing if True
            .FitToPagesWide = 1                 '1 page wide
            .FitToPagesTall = pt                'set to however many pages tall we determined earlier
            .PrintTitleRows = "$1:$1"           'print 1st row on each page as field header
        End With

    Next ws

END_SUB:

'    Debug.Print Timer - t                       'debug - time how long it took (exact time)
'    Debug.Print Format(Timer - t, "0.00")       'debug - time how long it took (nearest 100th sec)
    Application.ScreenUpdating = True           'switch screen updating back on
    Exit Sub

ERROR_HANDLER:

    Error_Detail                                'if an error occurs, dump out an error report
    GoTo END_SUB                                'go to end procedure

End Sub


'--------------------------------------------------
Sub Dupe_Check()
' compares data in rows to see if any exact matches are found
' then colors the exact-match rows if any are found. "exact
' match" in this case is any row that has the exact same data
' in each col as another col.
'
' EG:    col1    col2    col3
'        --------------------
' row1   dog     cat     bird
' row2   dog     cat     bird
' row3   dog     cat     pony
'       --------------------
'
' The first 2 rows would count as exact matches/dupes,
' and the sub will colorize the "A" col value to show such.
' The third row doesn't count as exact dupe, so it won't.
'
' Colorization of the dupes isn't color-coded by dupe.
' IE: all dupes get flagged with the same color (yellow-highlight).
' It's up to the user to investigate the colored rows and figure
' out which ones match which as dupes. (But, if you sort the data
' properly, this is simple.)
'
' This is a revised dupe check macro. Instead of iterating through
' a "source" range comparing to a "check" range, this one loads the
' data area into an array, then iterates through the array,
' comparing source array row to compare/check array row.  Runs twice
' as fast as the old range-to-range compare method, and 1.5x as fast
' as the range-to-array compare method. (b/c iterating through excel
' sheet model is slower then iterating through arrays).
'--------------------------------------------------

Dim rng As Range
Dim rSrc As Integer         'source row in array
Dim rChk As Integer         'check row in array (to compare to source row)
Dim rMax As Integer         'max rows in array
Dim cChk As Byte            'col being checked in array
Dim cMax As Byte            'max col's in array
Dim rngArray() As Variant   'array to load data set into for checking
Dim cmpArray() As String    'array to load compare strings into
Dim tTot As Single          'tracks total time cumulated during processing
Dim tSec As Single          'tracks 1 sec time to update status bar
Dim strSrc As String        'source compare string to build
Dim strChk As String        'check compare string to build

On Error GoTo ERROR_HANDLER             'error occurs when no workbook/worksheet open for operation, so end process

    Debug.Print ActiveWindow.Visible    'returns an error if no activewindow is visible, which makes button clicks get ignored

    tTot = Timer
    Application.Cursor = xlWait         'cursor = hourglass
    Set rng = ActiveSheet.Range("A1")
    rngArray = rng.CurrentRegion        'set array to data range (1-based counting)
    rMax = UBound(rngArray, 1)          'catch max rows in array
    cMax = UBound(rngArray, 2)          'catch max cols in array
    ReDim cmpArray(1 To rMax)

    'load the cmpArray with compare strings
    For rSrc = 1 To rMax                'for each "source" row
        For cChk = 1 To cMax            'build compare strings & populate cmpArray
            cmpArray(rSrc) = cmpArray(rSrc) + CStr(rngArray(rSrc, cChk))
        Next
    Next

    'go through cmpArray and compare source to check rows/strings for dupes
    For rSrc = 1 To rMax                'for each "source" row in cmpArray
        For rChk = 1 To rMax            'check each "check" row in cmpArray

            If rSrc <> rChk Then        'if source & check rows aren't the same
                If cmpArray(rSrc) = cmpArray(rChk) Then 'but the strings are (IE: dupes)
                    With rng
                        .Offset(rSrc - 1, 0).Interior.ColorIndex = 6 'tag source w/color
                        .Offset(rChk - 1, 0).Interior.ColorIndex = 6 'tag dupe w/color
                    End With
                End If
            End If

            If Timer - tSec > 1 Then 'every 1 sec, update status bar if needed
                tSec = Timer
                Application.StatusBar = "Checking..." & _
                    Round((rSrc / rMax) * 100, 0) & "%" _
                    & " (~" & Round((rMax - rSrc) / 500) & " secs remaining)"
                    'can do ~500 rows / sec, so used that for generic "time left"
            End If
        
        Next    'rChk
    Next

    With Application
        .Cursor = xlDefault                  'remove hourglass
        .StatusBar = False
    End With

    Debug.Print Format(Timer - tTot, "0.00")
    MsgBox "Done"

END_SUB:

    Exit Sub

ERROR_HANDLER:

    Error_Detail                            'if an error occurs, dump out an error report
    GoTo END_SUB                            'go to end procedure

End Sub

vba_excel_utils_sql.bas

'--------------------------------------------------
' Misc SQL-related Utilities for Excel
'--------------------------------------------------
' Use the "Error_Detail" sub from "vba_excel_utils.bas",
' So make sure that module is in the same workbook /
' project you're working in (or just copy/paste that
' sub and the public error var into this if you want
' to use this stand-alone.)
'--------------------------------------------------

Option Explicit

'--------------------------------------------------
Sub SQL_IN_string()
'
' Takes highlighted selection, and concats values
' into SQL-ready IN string dumped to new worksheet,
' so won't destroy anything you're working on.
' Useful when you're analyzing a data set you dumped
' from a SQL system, and need to make a new query
' to pull specific things from it going forward.
'
' EG: I'd analyze customer features, and notice
'     certain ones borking up. So, I'd SQL IN on
'     the specific ones I needed to run a QA SQL
'     check on going forward.
'--------------------------------------------------

Dim s As String
Dim c As Variant              'generic "cell" object to iterate through "cells" group
Dim wb As Excel.Workbook      'throw-away work-book to toss resulting sql string into
Dim ws As Excel.Worksheet     'throw-away work-sheet to toss resulting sql string into

On Error GoTo ERROR_HANDLER                 'error will occur if no workbook/worksheet is open for selection to take effect

    Debug.Print ActiveWindow.Visible        'returns an error if no activewindow is visible, which makes button clicks get ignored

    For Each c In Selection.Cells           'go through each cell in selection
        s = s & "'" & c.Value & "', "       'add cell's value to IN string (with single-quotes)
    Next c

    Set wb = Workbooks.Add                  'make a new workbook and sheet to toss the string into
    Set ws = wb.Sheets("Sheet1")            'this way, user's selection in other workbook stays selected
    ws.Range("A1").Value = "(" & Left(s, Len(s) - 2) & ")" 'paste in our sql IN string
    wb.Saved = True                         'make it seem like the wb's been saved, so it won't bug user to do so when they close it

END_SUB:
    
    Exit Sub

ERROR_HANDLER:

    Error_Detail                            'if an error occurs, dump out an error report
    GoTo END_SUB                            'go to end procedure

End Sub


'--------------------------------------------------
Sub SQL_Query()
' uses ADODB lib, so need to checkmark that in
' your VBA environment you're using this in.
'
' Concats highlighted selection, and runs it as a
' SQL statement against a ADODB connection string
' you provide. Then spits out the resulting data
' and nicely formats it.
'
' Coded for older Excel versions, so has 255 col &
' ~65k row limit.
'
' uses the "Reset_Mouse_Status" from "vba_excel_utils"
' to reset Excel environment for user use again. So,
' have these modules in the same workbook or project.
'
' Good for quickn-n-dirty data pulls.
'
' I had all these functions in an XLA workbook that
' would auto-load when I'd open Excel, and on one
' of the worksheets in it I had common variables
' stored, one of which was the conn string to the
' server I was working on regularly. Hence why it's
' coded to look at a worksheet cell for a conn value.
'
' You'll need to modify the code to point to a conn
' of your choice.
'--------------------------------------------------

Dim connStr As String                       'connection string to let connection know which server to tap and run sql against
Dim conn As ADODB.Connection                'adodb connection to SQL server
Dim rs As ADODB.Recordset                   'adodb recordset obj
Dim sql As String                           'sql string built from selection and used to query up recordset
Dim ws As Excel.Worksheet                   'xl worksheet
Dim rng As Range                            'xl range
Dim c As Variant                            'generic "cell" interator
Dim l As Long                               'row counter
Dim msg As String                           'feedback msg
Dim rCount As Long                          'record count

On Error GoTo ERROR_HANDLER

    Debug.Print ActiveWindow.Visible        'returns an error if no activewindow is visible, which makes button clicks get ignored

    Application.Cursor = xlWait             'cursor = hourglass
    
    l = Selection.Row                       'set l to initial row of selection (IE: 1st row of selection)
    sql = ""                                'clear out sql var (don't have to do, but if I make it a public var, then I will, so doing so now just in case)


    For Each c In Selection.Cells
        With c
            
            If l < .Row Then                'if the cell starts on a new row
                sql = RTrim(sql) & vbCrLf    'add a carrige return to the sql string (so next cells will go to new line, more for user feedback / viewing, because the sql compiler doesn't care)
                l = .Row                    'increment the comparison variable to the new row
'               debug.print l               'check what row we've moved to
            End If

            If c.Row = l Then               'if cell is on same row we're currently on
                If Left(.Value, 2) <> "--" Then 'if it's not commented out (sql comment = "--")
                    sql = sql & " " & .Value  'add it's value (plus a space, just in case) to the text string
                Else                        'otherwise..
                    sql = Trim(sql) & vbCrLf 'add a carrige return to the sql string (so next cells will go to new line, more for user feedback / viewing, because the sql compiler doesn't care)
                    l = l + 1               'increment the row by 1 to skip all the rest of the cells in this row (they're commented out)
                End If
            End If

        End With 'c
    Next c

    Debug.Print sql                         'check to see compiled sql string

    Set conn = New ADODB.Connection         'new conn instance
    Set rs = New ADODB.Recordset            'new rs instance
    
    'connection string is stored in the Add-in (XLA) file, on sheet called "variables"
    'to reference it, we drill-down from workbook, to sheet, to range it's stored in
    'while the source file is XLS format, the Add-in, when compiled and used, will be XLA...
    '...so, we reference the XLA version of the workbook here, not the XLS version
    'later on, I may make it where user can open a small sub-form and alter the connection string,
    'saving it back to the "variables" sheet...but for now, it's whatever I've made it during the compile time

' !!! you'll need to figure out your conn string here !!!

'    connStr = Workbooks("PRODDEV_TOOLS.XLS").Worksheets("variables").Range("C2").Value
    connStr = Workbooks("PRODDEV_TOOLS.XLA").Worksheets("variables").Range("C2").Value
    
    conn.Open connStr                       'open connection using connStr

    With rs
        .Open sql, conn, adOpenStatic, adLockReadOnly 'open static, read-only rs, using sql & conn made forwardonly is faster, but using static so we can call the .RecordCount property

        rCount = .RecordCount

' !!! might want to modify the row count limit to suit your Excel version !!!

        If rCount > 65535 Then                   'if there's more records than excel can fit on a sheet (65536 - 1 row for header row)
            
            'ask user if they want to keep going...
            msg = "This query pulled " & FormatNumber(rCount, 0) & " records..." & FormatNumber(rCount - 65535, 0) & " more than an Excel sheet can handle." & vbCrLf & vbCrLf
            msg = msg & "(Excel sheets max out at 65,536 rows, and we're using the 1st row for your field headers.  So, your results minus 65,535 equals the overage...)" & vbCrLf & vbCrLf
            msg = msg & "I can pull the data in, but those extra records will get truncated from the sheet." & vbCrLf & vbCrLf
            msg = msg & "Are you sure you want me to pull it in?  (NO = Cancel)"

            l = MsgBox(msg, vbYesNo, "Returned more records than can fit on an Excel sheet...")

            If l = vbNo Then                    'if user decides they don't want to proceed with record truncate
                GoTo END_SUB                    'go to exit and clean up before ending
            End If
            
        ElseIf rCount < 1 Then                  'if 0 records, or if BOF = EOF (-1 records), let use know and exit

            msg = "The query returned " & FormatNumber(rCount, 0) & " records." & vbCrLf & vbCrLf
            msg = msg & "Dump the field headers into a new sheet anyways?  (NO = Cancel)"
            
            l = MsgBox(msg, vbYesNo, "No Records...")

            If l = vbNo Then                    'if user decides they don't want to proceed with record truncate
                GoTo END_SUB                    'go to exit and clean up before ending
            End If
        
        End If

        'make new worksheet after rs opens, so if it fails, we don't clutter up user's workbook with a blank sheet
        Set ws = ActiveWorkbook.Sheets.Add      'make a new worksheet to dump the query results to
        Set rng = ws.Range("A1")                'set anchor point where we'll fill in field headers and dump data
    
        For l = 0 To (.Fields.Count - 1)        'fill in field headers (and there shouldn't be more then 255 of them)
            rng.Offset(0, l).Value = .Fields(l).Name
            
            'if data in field is formated as date, make column format as date, too
            If rCount > 0 Then                  'only do date value check if 1+ records showed up, else we get a BOF = EOF error
                If .Fields(l).Value Like "*#/*#/#*" Then
                    rng.Offset(0, l).EntireColumn.NumberFormat = "m/d/yy"
                End If
            End If
        
        Next l
    End With


    With rng
        .Offset(1, 0).CopyFromRecordset rs  'transfer recordset to datasheet (1 row below field headers)
        .AutoFormat                         'format data and sheet
        .Offset(1, 0).Select
        .Application.ActiveWindow.FreezePanes = True
    End With

END_SUB:

    If Not rs Is Nothing Then               'if rs is set to something
        If rs.State = 1 Then                'if it's open
            rs.Close                        'close it
        End If

        Set rs = Nothing                    'clear it from memory
    End If
    
    
    If Not conn Is Nothing Then             'if conn is set to something
        If conn.State = 1 Then              'if it's open
            conn.Close                      'close it
        End If
        
        Set conn = Nothing                  'clear it from memory
    End If

    Reset_Mouse_Status                      'reset the mouse and other visual elements before exiting
    Exit Sub                                'cut out of the sub

ERROR_HANDLER:

    Error_Detail                            'if an error occurs, compile error detail
    
    msg = "Something blew up, Dude..." & vbCrLf 'let user know something blew up
    msg = msg & String(50, "-") & vbCrLf            'border-split the next part
    msg = msg & ErrorMsg & vbCrLf
    msg = msg & String(50, "-") & vbCrLf            'border-split the next part
    msg = msg & "POSSIBLE CAUSES:" & vbCrLf & vbCrLf
    msg = msg & "- Your highlighted selection may not be a valid SQL statement.  If so, the error message above can give a hint as to where it's wrong.  Correct the statement & re-highlight it, or change your selection highlight to a correct statement." & vbCrLf & vbCrLf
    msg = msg & "- Your highlighted selection may contain #NAME? error cells.  Correct by removing the equal sign, and replacing with a single-quote to make it count as text instead of a formula." & vbCrLf & vbCrLf
    msg = msg & "- The server connection may be down, or your computer may not be set up to allow access to it."

    MsgBox msg, vbCritical, "PROBLEM"

    GoTo END_SUB                            'go to end procedure

End Sub