Cool VBA Scripting
We use My Survey MySQL to record visitors to the museum. Unfortunately, My Survey records to the exact second each entry is recorded. We also chose to record zip codes for each visitor. That posed an interesting problem, since My Survey simply sorts the data as input, giving us no way to display by month, or sort the zip codes by state, unless mucho hacking took place, and I'm no perl dude...
Since our Development Director along with the Marketing Commitee needed a more resonable way to view this, I decided to use Excel and VBA. My Survey allows the user to export a csv file, so the following code works like a champ in a code module for Excel:
The CRAP is what was lifted. ZIP is "=--RIGHT(A2,5)", STATE is "=VLOOKUP(LEFT(A2,2), $G$2:$H$52,2,0)" and the ABB and FULL NAME is used just for the VLOOKUP.
Cool...have fun.
Option Explicit Dim intRow As Integer, sCol As String, rRange As String Dim szFilter As String Dim szTitle As String Dim szFile As String, intReturn As Integer, intCount As Integer, blnFilled As Boolean Sub SelectCSV() szFilter = "Survey Files (*.csv),*.csv" szTitle = "Please Select a survey File" szFile = Application.GetOpenFilename(szFilter, , szTitle) ' This makes sure the correct file is used, since nothing else works. If szFile <> "False" Then If LCase(Right$(szFile, 10)) <> "survey.csv" Then MsgBox "Bad Filename!", vbCritical, "Error" End If End If End Sub Sub auto_open() ' ' Insert_Data 'Open the file Call SelectCSV 'This can be "broken" by hitting ESC twice... If szFile = "False" Then intReturn = MsgBox("Would you like to try again?", vbYesNo, "Try Again?") Select Case intReturn Case Is = 6 Call SelectCSV Case Is = 7 Application.Quit End Select End If 'Insert a new sheet Sheets.Add ActiveSheet.Name = "Data" With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & szFile, Destination:=Range("A2")) .Name = "survey" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = xlWindows .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = True .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 2, 1, 2, 2, 2, 2, 1) .Refresh BackgroundQuery:=False End With 'Location of last row intRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count ' ' Insert_Header ' Range("A1").Select ActiveCell.FormulaR1C1 = "ZIP" Range("B1").Select ActiveCell.FormulaR1C1 = "AGE" Range("C1").Select ActiveCell.FormulaR1C1 = "GENDER" Range("D1").Select ActiveCell.FormulaR1C1 = "DATE (Web)" Range("E1").Select ActiveCell.FormulaR1C1 = "MEMBER" Range("F1").Select ActiveCell.FormulaR1C1 = "RACE" Range("G1").Select ActiveCell.FormulaR1C1 = "TYPE" Range("H1").Select ActiveCell.FormulaR1C1 = "DIABILITY" Rows("1:1").Select Selection.Font.Bold = True With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With Columns("H:H").EntireColumn.AutoFit Columns("E:E").EntireColumn.AutoFit Columns("D:D").EntireColumn.AutoFit Columns("B:B").Select Selection.Insert Shift:=xlToRight Range("B1").Select ActiveCell.FormulaR1C1 = "STATE" Range("B2").Select ' ' Insert_State_Data ' ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],ZipCodes!R2C2:R33108C3,2,FALSE)" Range("B2").Select sCol = "B" rRange = sCol & intRow Range("B2", rRange).Select Selection.FillDown ActiveWindow.ScrollRow = 1 ' Insert_Visitor_By_State ' Sheets("ZipCodes").Select Range("H1:H52").Select Range("H52").Activate Selection.Copy Sheets("Data").Select Range("K1").Select Columns("K:K").ColumnWidth = 36.71 ActiveSheet.Paste ActiveWindow.ScrollColumn = 3 Range("L1").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "VISITORS" Range("K1").Select ActiveCell.FormulaR1C1 = "STATE" Range("L2").Select 'ActiveCell.FormulaR1C1 = "=COUNTIF("B2:R" & intRow & "C[-10],RC[-1])" ActiveCell.FormulaR1C1 = "=COUNTIF(R2C[-10]:R" & intRow & "C[-10], RC11)" Range("L2").Select Selection.AutoFill Destination:=Range("L2:L52"), Type:=xlFillDefault Range("L2:L52").Select Range("K2:L52").Select Range("L52").Activate Selection.Font.Bold = True ' Human_Readable_Date ' Since the date recorded by My Survey is in Unix Time stamp (# secs from Jan 1, 1970) Range("J1").Select ActiveCell.FormulaR1C1 = "DATE" Range("J2").Select ActiveCell.FormulaR1C1 = "=RC[-5]/86400+DATE(1970,1,1)" Range("J2").Select sCol = "J" rRange = sCol & intRow Range("J2", rRange).Select Selection.FillDown Selection.NumberFormat = "mm/yyyy" ' Visitor_By_Date ' Range("M1").Select ActiveCell.FormulaR1C1 = "YEAR" Range("M2").Select ActiveCell.FormulaR1C1 = "2003" Selection.AutoFill Destination:=Range("M2:M13"), Type:=xlFillDefault Range("M14").Select ActiveCell.FormulaR1C1 = "2004" Selection.AutoFill Destination:=Range("M14:M25"), Type:=xlFillDefault Range("M26").Select ActiveCell.FormulaR1C1 = "2005" Selection.AutoFill Destination:=Range("M26:M37"), Type:=xlFillDefault Range("M38").Select ActiveCell.FormulaR1C1 = "2006" Selection.AutoFill Destination:=Range("M38:M49"), Type:=xlFillDefault Range("N1").Select ActiveCell.FormulaR1C1 = "MONTH" Range("O1").Select ActiveCell.FormulaR1C1 = "VISITOR" Range("O2").Select ActiveCell.FormulaR1C1 = "=SUMPRODUCT((YEAR(R2C10:R" & intRow & "C10)=RC13)*(MONTH(R2C10:R" & intRow & "C10)=RC16)*1)" Range("O2").Select Selection.AutoFill Destination:=Range("O2:O49"), Type:=xlFillDefault 'Populate the number of month for calculations 'select our first cell Range("P2").Select 'set the counter intCount = 1 Do While intCount < 13 ActiveCell.FormulaR1C1 = intCount ActiveCell.Offset(1, 0).Select intCount = intCount + 1 Loop 'select our next cell Range("P14").Select 'reset counter intCount = 1 Do While intCount < 13 ActiveCell.FormulaR1C1 = intCount ActiveCell.Offset(1, 0).Select intCount = intCount + 1 Loop 'select our next cell Range("P26").Select 'reset counter intCount = 1 Do While intCount < 13 ActiveCell.FormulaR1C1 = intCount ActiveCell.Offset(1, 0).Select intCount = intCount + 1 Loop 'select our next cell Range("P38").Select 'reset counter intCount = 1 Do While intCount < 13 ActiveCell.FormulaR1C1 = intCount ActiveCell.Offset(1, 0).Select intCount = intCount + 1 Loop ' Insert a user friendly date format for the chart Range("N2").Select ActiveCell.FormulaR1C1 = "JAN '03" Range("N3").Select ActiveCell.FormulaR1C1 = "FEB '03" Range("N4").Select ActiveCell.FormulaR1C1 = "MAR '03" Range("N5").Select ActiveCell.FormulaR1C1 = "APRIL '03" Range("N6").Select ActiveCell.FormulaR1C1 = "MAY '03" Range("N7").Select ActiveCell.FormulaR1C1 = "JUNE '03" Range("N8").Select ActiveCell.FormulaR1C1 = "JULY '03" Range("N9").Select ActiveCell.FormulaR1C1 = "AUG '03" Range("N10").Select ActiveCell.FormulaR1C1 = "SEPT '03" Range("N11").Select ActiveCell.FormulaR1C1 = "OCT '03" Range("N12").Select ActiveCell.FormulaR1C1 = "NOV '03" Range("N13").Select ActiveCell.FormulaR1C1 = "DEC '03" Range("N14").Select ActiveCell.FormulaR1C1 = "JAN '04" Range("N15").Select ActiveCell.FormulaR1C1 = "FEB '04" Range("N16").Select ActiveCell.FormulaR1C1 = "MAR '04" Range("N17").Select ActiveCell.FormulaR1C1 = "APRIL '04" Range("N18").Select ActiveCell.FormulaR1C1 = "MAY '04" Range("N19").Select ActiveCell.FormulaR1C1 = "JUNE '04" Range("N20").Select ActiveCell.FormulaR1C1 = "JULY '04" Range("N21").Select ActiveCell.FormulaR1C1 = "AUG '04" Range("N22").Select ActiveCell.FormulaR1C1 = "SEPT '04" Range("N23").Select ActiveCell.FormulaR1C1 = "OCT '04" Range("N24").Select ActiveCell.FormulaR1C1 = "NOV '04" Range("N25").Select ActiveCell.FormulaR1C1 = "DEC '04" Range("N26").Select ActiveCell.FormulaR1C1 = "JAN '05" Range("N27").Select ActiveCell.FormulaR1C1 = "FEB '05" Range("N28").Select ActiveCell.FormulaR1C1 = "MAR '05" Range("N29").Select ActiveCell.FormulaR1C1 = "APR '05" Range("N30").Select ActiveCell.FormulaR1C1 = "MAY '05" Range("N31").Select ActiveCell.FormulaR1C1 = "JUNE '05" Range("N32").Select ActiveCell.FormulaR1C1 = "JULY '05" Range("N33").Select ActiveCell.FormulaR1C1 = "AUG '05" Range("N34").Select ActiveCell.FormulaR1C1 = "SEPT '05" Range("N35").Select ActiveCell.FormulaR1C1 = "OCT '05" Range("N36").Select ActiveCell.FormulaR1C1 = "NOV '05" Range("N37").Select ActiveCell.FormulaR1C1 = "DEC '05" Range("N38").Select ActiveCell.FormulaR1C1 = "JAN '06" Range("N39").Select ActiveCell.FormulaR1C1 = "FEB '06" Range("N40").Select ActiveCell.FormulaR1C1 = "MAR '06" Range("N41").Select ActiveCell.FormulaR1C1 = "APRIL '06" Range("N42").Select ActiveCell.FormulaR1C1 = "MAY '06" Range("N43").Select ActiveCell.FormulaR1C1 = "JUNE '06" Range("N44").Select ActiveCell.FormulaR1C1 = "JULY '06" Range("N45").Select ActiveCell.FormulaR1C1 = "AUG '06" Range("N46").Select ActiveCell.FormulaR1C1 = "SEPT '06" Range("N47").Select ActiveCell.FormulaR1C1 = "OCT '06" Range("N48").Select ActiveCell.FormulaR1C1 = "NOV '06" Range("N49").Select ActiveCell.FormulaR1C1 = "DEC '06" Range("M1:O49").Select Selection.Font.Bold = True ' Chart_By_State ' Range("K1:L60").Select Charts.Add ActiveChart.ChartType = xl3DBarClustered ActiveChart.SetSourceData Source:=Sheets("Data").Range("K1:L52"), PlotBy:= _ xlColumns ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Visitor By State" With ActiveChart .HasTitle = False .Axes(xlCategory).HasTitle = False .Axes(xlSeries).HasTitle = False .Axes(xlValue).HasTitle = False End With With ActiveChart .HasAxis(xlCategory) = True .HasAxis(xlSeries) = False .HasAxis(xlValue) = True End With ActiveChart.Axes(xlCategory).CategoryType = xlAutomatic ActiveChart.HasLegend = False ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False ActiveChart.HasDataTable = False With ActiveChart.PageSetup .Orientation = xlPortrait End With ActiveChart.Walls.Select ActiveChart.PlotArea.Select ActiveChart.Axes(xlCategory).Select Selection.TickLabels.AutoScaleFont = True With Selection.TickLabels.Font .Name = "Avenir 35 Light" .Size = 5 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With 'Chart by month '03 Sheets("Data").Select Range("O2").Select intCount = 1 Do While intCount < 13 If ActiveCell = 0 Then blnFilled = False Else blnFilled = True Exit Do End If intCount = intCount + 1 ActiveCell.Offset(1, 0).Select Loop If blnFilled = True Then Range("N1:O13").Select Charts.Add ActiveChart.ChartType = xlPie ActiveChart.SetSourceData Source:=Sheets("Data").Range("N1:O13"), PlotBy:= _ xlColumns ActiveChart.Location Where:=xlLocationAsNewSheet, Name:= _ "Visitors By Month '03" With ActiveChart .HasTitle = True .ChartTitle.Characters.Text = "Vistors By Month '03" End With ActiveChart.HasLegend = True ActiveChart.Legend.Select Selection.Position = xlLeft ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False, _ HasLeaderLines:=True ActiveChart.Legend.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 9 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With Selection.Height = 187 ActiveChart.SeriesCollection(1).DataLabels.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ActiveChart.ChartTitle.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Bold" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With End If blnFilled = False 'Chart by month '04 Sheets("Data").Select Range("O14").Select intCount = 1 Do While intCount < 13 If ActiveCell = 0 Then blnFilled = False Else blnFilled = True Exit Do End If intCount = intCount + 1 ActiveCell.Offset(1, 0).Select Loop If blnFilled = True Then Range("N14:O25").Select Charts.Add ActiveChart.ChartType = xlPie ActiveChart.SetSourceData Source:=Sheets("Data").Range("N14:O25"), PlotBy:= _ xlColumns ActiveChart.Location Where:=xlLocationAsNewSheet, Name:= _ "Visitors By Month '04" With ActiveChart .HasTitle = True .ChartTitle.Characters.Text = "Vistors By Month '04" End With ActiveChart.HasLegend = True ActiveChart.Legend.Select Selection.Position = xlLeft ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False, _ HasLeaderLines:=True ActiveChart.Legend.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 9 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With Selection.Height = 187 ActiveChart.SeriesCollection(1).DataLabels.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ActiveChart.ChartTitle.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Bold" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With End If blnFilled = False 'Chart by month '05 Sheets("Data").Select Range("O26").Select intCount = 1 Do While intCount < 13 If ActiveCell = 0 Then blnFilled = False Else blnFilled = True Exit Do End If intCount = intCount + 1 ActiveCell.Offset(1, 0).Select Loop If blnFilled = True Then Range("N26:O37").Select Charts.Add ActiveChart.ChartType = xlPie ActiveChart.SetSourceData Source:=Sheets("Data").Range("N26:O37"), PlotBy:= _ xlColumns ActiveChart.Location Where:=xlLocationAsNewSheet, Name:= _ "Visitors By Month '05" With ActiveChart .HasTitle = True .ChartTitle.Characters.Text = "Vistors By Month '05" End With ActiveChart.HasLegend = True ActiveChart.Legend.Select Selection.Position = xlLeft ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False, _ HasLeaderLines:=True ActiveChart.Legend.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 9 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With Selection.Height = 187 ActiveChart.SeriesCollection(1).DataLabels.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ActiveChart.ChartTitle.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Bold" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With End If blnFilled = False 'Chart by month '06 Sheets("Data").Select Range("O38").Select intCount = 1 Do While intCount < 13 If ActiveCell = 0 Then blnFilled = False Else blnFilled = True Exit Do End If intCount = intCount + 1 ActiveCell.Offset(1, 0).Select Loop If blnFilled = True Then Range("N38:O49").Select Charts.Add ActiveChart.ChartType = xlPie ActiveChart.SetSourceData Source:=Sheets("Data").Range("N38:O49"), PlotBy:= _ xlColumns ActiveChart.Location Where:=xlLocationAsNewSheet, Name:= _ "Visitors By Month '06" With ActiveChart .HasTitle = True .ChartTitle.Characters.Text = "Vistors By Month '06" End With ActiveChart.HasLegend = True ActiveChart.Legend.Select Selection.Position = xlLeft ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False, _ HasLeaderLines:=True ActiveChart.Legend.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 9 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With Selection.Height = 187 ActiveChart.SeriesCollection(1).DataLabels.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Regular" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ActiveChart.ChartTitle.Select Selection.AutoScaleFont = True With Selection.Font .Name = "Avenir 35 Light" .FontStyle = "Bold" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With End If blnFilled = False ' Set this workbook saved to discourage saving ThisWorkbook.Saved = True End SubThen make sure you put the following in the "ThisWorkbook" object code area:
Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = False Else Cancel = True End SubThis prevents the "Do you want to save changes?" dialog, since the ThisWorkbook.Saved = True flag is set. The ZipCodes page contains a list of zipcodes lifted from the US Census website. You'll have to use something like this:
CRAP | ZIP | STATE |   |   |   | ABB | FULL NAME |
AL35004 | 35004 | ALABAMA |   |   |   | AL | ALABAMA |
Comments