Skip to content

Instantly share code, notes, and snippets.

@ccritchfield

ccritchfield/_vba_excel_utils.readme

Created December 5, 2019 16:52
Show Gist options
  • Save ccritchfield/7174c7ef050e3bfbad82aae34c156789 to your computer and use it in GitHub Desktop.
Save ccritchfield/7174c7ef050e3bfbad82aae34c156789 to your computer and use it in GitHub Desktop.
Download ZIP
VBA -
Raw
_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.
Raw
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
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment