diff --git a/src/code/Chart_Axes.bas b/src/code/Chart_Axes.bas index 5b76201..e7b75ea 100644 --- a/src/code/Chart_Axes.bas +++ b/src/code/Chart_Axes.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Chart_Axes" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Chart_Axes ' Author : @byronwall @@ -68,20 +70,20 @@ End Sub '--------------------------------------------------------------------------------------- ' Sub Chart_FitAxisToMaxAndMin(xlCat As XlAxisType) - - Dim first As Boolean - first = True - Dim cht_obj As ChartObject - For Each cht_obj In Chart_GetObjectsFromObject(Selection) + '2015 11 09 moved first inside loop so that it works for multiple charts + Dim first As Boolean + first = True + Dim cht As Chart Set cht = cht_obj.Chart Dim ser As series For Each ser In cht.SeriesCollection - Dim min_val As Double, max_val As Double + Dim min_val As Double + Dim max_val As Double If xlCat = xlCategory Then @@ -124,7 +126,7 @@ End Sub ' Flags : not-used '--------------------------------------------------------------------------------------- ' -Sub Chart_YAxisRangeWithAvgAndStdev() +Public Sub Chart_YAxisRangeWithAvgAndStdev() Dim dbl_std As Double dbl_std = CDbl(InputBox("How many standard deviations to include?")) diff --git a/src/code/Chart_Format.bas b/src/code/Chart_Format.bas index cedf827..fa30817 100644 --- a/src/code/Chart_Format.bas +++ b/src/code/Chart_Format.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Chart_Format" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Chart_Format ' Author : @byronwall @@ -111,6 +113,10 @@ Sub Chart_AxisTitleIsSeriesTitle() cht.Axes(xlValue, ser.AxisGroup).HasTitle = True cht.Axes(xlValue, ser.AxisGroup).AxisTitle.Text = b_ser.name + + '2015 11 11, adds the x-title assuming that the name is one cell above the data + cht.Axes(xlCategory).HasTitle = True + cht.Axes(xlCategory).AxisTitle.Text = b_ser.XValues.Cells(1, 1).Offset(-1).Value Next ser Next cht_obj diff --git a/src/code/Chart_Helpers.bas b/src/code/Chart_Helpers.bas index 496cd59..4dbcf6e 100644 --- a/src/code/Chart_Helpers.bas +++ b/src/code/Chart_Helpers.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Chart_Helpers" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Chart_Helpers ' Author : @byronwall diff --git a/src/code/Chart_Processing.bas b/src/code/Chart_Processing.bas index c6019d6..da2acd5 100644 --- a/src/code/Chart_Processing.bas +++ b/src/code/Chart_Processing.bas @@ -8,6 +8,57 @@ Attribute VB_Name = "Chart_Processing" Option Explicit +Public Sub Chart_CreateChartWithSeriesForEachColumn() +'will create a chart that includes a series with no x value for each column + + Dim rng_data As Range + Set rng_data = GetInputOrSelection("Select chart data") + + 'create a chart + Dim cht_obj As ChartObject + Set cht_obj = ActiveSheet.ChartObjects.Add(0, 0, 300, 300) + + cht_obj.Chart.ChartType = xlXYScatter + + Dim rng_col As Range + For Each rng_col In rng_data.Columns + + Dim rng_chart As Range + Set rng_chart = RangeEnd(rng_col.Cells(1, 1), xlDown) + + Dim b_ser As New bUTLChartSeries + Set b_ser.Values = rng_chart + + b_ser.AddSeriesToChart cht_obj.Chart + Next + +End Sub + +Public Sub Chart_CopyToSheet() + + Dim cht_obj As ChartObject + + Dim obj_all As Object + Set obj_all = Selection + + Dim msg_newSheet As VbMsgBoxResult + msg_newSheet = MsgBox("New sheet?", vbYesNo, "New sheet?") + + Dim sht_out As Worksheet + If msg_newSheet = vbYes Then + Set sht_out = Worksheets.Add() + Else + Set sht_out = Application.InputBox("Pick a cell on a sheet", "Pick sheet", Type:=8).Parent + End If + + For Each cht_obj In Chart_GetObjectsFromObject(obj_all) + cht_obj.Copy + + sht_out.Paste + Next + + sht_out.Activate +End Sub Sub Chart_SortSeriesByName() 'this will sort series by names diff --git a/src/code/Chart_Series.bas b/src/code/Chart_Series.bas index 0e49f4d..93d1460 100644 --- a/src/code/Chart_Series.bas +++ b/src/code/Chart_Series.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Chart_Series" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Chart_Series ' Author : @byronwall @@ -42,7 +44,11 @@ Sub Chart_AddTrendlineToSeriesAndColor() Set trend = ser.Trendlines.Add() trend.Type = xlLinear trend.Border.Color = ser.MarkerBackgroundColor - trend.name = b_ser.name + + '2015 11 06 test to avoid error without name + If Not b_ser.name Is Nothing Then + trend.name = b_ser.name + End If trend.DisplayEquation = True trend.DisplayRSquared = True diff --git a/src/code/Formatting_Helpers.bas b/src/code/Formatting_Helpers.bas index de75441..6277e35 100644 --- a/src/code/Formatting_Helpers.bas +++ b/src/code/Formatting_Helpers.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Formatting_Helpers" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Formatting_Helpers ' Author : @byronwall @@ -131,11 +133,13 @@ Public Sub Colorize() Set rngToColor = GetInputOrSelection("Select range to color") Dim lastrow As Integer lastrow = rngToColor.Rows.count - + + Dim likevalues As VbMsgBoxResult likevalues = MsgBox("Do you want to keep duplicate values the same color?", vbYesNo) If likevalues = vbNo Then - + + Dim i As Integer For i = 1 To lastrow If i Mod 2 = 0 Then rngToColor.Rows(i).Interior.Color = RGB(200, 200, 200) @@ -194,8 +198,10 @@ Sub CombineCells() 'Read input rows into a single string Dim strOutput As String + Dim i As Integer For i = 1 To x strOutput = vbNullString + Dim j As Integer For j = 1 To y strOutput = strOutput & strDelim & rngInput(i, j) Next @@ -296,6 +302,8 @@ Sub CopyTranspose() errCancel: End Sub + + '--------------------------------------------------------------------------------------- ' Procedure : CreateConditionalsForFormatting ' Author : @byronwall @@ -310,7 +318,8 @@ Sub CreateConditionalsForFormatting() 'add these in as powers of 3, starting at 1 = 10^0 Dim arrMarkers As Variant arrMarkers = Array("", "k", "M", "B") - + + Dim i As Integer For i = UBound(arrMarkers) To 0 Step -1 With rngInput.FormatConditions.Add(xlCellValue, xlGreaterEqual, 10 ^ (3 * i)) @@ -341,6 +350,8 @@ Sub ExtendArrayFormulaDown() Set rngArrForm = Selection For Each RngArea In rngArrForm.Areas + + Dim c As Range For Each c In RngArea.Cells If c.HasArray Then @@ -382,6 +393,9 @@ Sub MakeHyperlinks() On Error GoTo errHandler Dim rngEval As Range Set rngEval = GetInputOrSelection("Select the range of cells to convert to hyperlink") + + 'TODO: choose a better variable name + Dim c As Range For Each c In rngEval ActiveSheet.Hyperlinks.Add Anchor:=c, Address:=c Next c @@ -399,7 +413,8 @@ End Sub '--------------------------------------------------------------------------------------- ' Sub OutputColors() - + + Dim i As Integer For i = 1 To 10 ActiveCell.Offset(i).Interior.Color = Chart_GetColor(i) Next i @@ -419,6 +434,7 @@ Sub SelectedToValue() On Error GoTo errHandler Set rng = GetInputOrSelection("Select the formulas you'd like to convert to static values") + Dim c As Range For Each c In rng c.Value = c.Value Next c @@ -587,7 +603,8 @@ Sub TrimSelection() Dim rngToTrim As Range On Error GoTo errHandler Set rngToTrim = GetInputOrSelection("Select the formulas you'd like to convert to static values") - + + Dim c As Range For Each c In rngToTrim c.Value = Trim(c.Value) Next c diff --git a/src/code/RandomCode.bas b/src/code/RandomCode.bas index 9cf5f53..4c360ef 100644 --- a/src/code/RandomCode.bas +++ b/src/code/RandomCode.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "RandomCode" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : RandomCode ' Author : @byronwall @@ -174,7 +176,7 @@ Sub Rand_DownloadFromSheet() For Each rng_addr In Range("B2:B35") - Download_File rng_add, str_folder & rng_addr.Offset(, 1) + Download_File rng_addr, str_folder & rng_addr.Offset(, 1) Next rng_addr diff --git a/src/code/Ribbon_Callbacks.bas b/src/code/Ribbon_Callbacks.bas index ea19e99..42ce4dc 100644 --- a/src/code/Ribbon_Callbacks.bas +++ b/src/code/Ribbon_Callbacks.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Ribbon_Callbacks" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Ribbon_Callbacks ' Author : @byronwall @@ -113,7 +115,7 @@ Public Sub btn_convertValue_onAction(control As IRibbonControl) End Sub Public Sub btn_copyClear_onAction(control As IRibbonControl) - CopyClear + MsgBox "Copy clear is missing" End Sub Public Sub btn_cutTranspose_onAction(control As IRibbonControl) @@ -162,7 +164,7 @@ Public Sub btn_protect_onAction(control As IRibbonControl) End Sub Public Sub btn_rmvComments_onAction(control As IRibbonControl) - RemoveComments + MsgBox "RemoveComments missing" End Sub Public Sub btn_seriesSplit_onAction(control As IRibbonControl) diff --git a/src/code/Sheet_Helpers.bas b/src/code/Sheet_Helpers.bas index d932816..a5ad71f 100644 --- a/src/code/Sheet_Helpers.bas +++ b/src/code/Sheet_Helpers.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Sheet_Helpers" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Sheet_Helpers ' Author : @byronwall @@ -24,9 +26,10 @@ Sub LockAllSheets() Application.ScreenUpdating = False 'Changed to activeworkbook so if add-in is not installed, it will target the active book rather than the xlam - For Each Sheet In ActiveWorkbook.Sheets + Dim sheet As Worksheet + For Each sheet In ActiveWorkbook.Sheets On Error Resume Next - Sheet.Protect (pass) + sheet.Protect (pass) Next Application.ScreenUpdating = True diff --git a/src/code/SubsFuncs_Helpers.bas b/src/code/SubsFuncs_Helpers.bas index 0d002d3..9fbb5d1 100644 --- a/src/code/SubsFuncs_Helpers.bas +++ b/src/code/SubsFuncs_Helpers.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "SubsFuncs_Helpers" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : SubsFuncs_Helpers ' Author : @byronwall diff --git a/src/code/Testing.bas b/src/code/Testing.bas index 0e9e69a..309c564 100644 --- a/src/code/Testing.bas +++ b/src/code/Testing.bas @@ -1,110 +1,172 @@ Attribute VB_Name = "Testing" Option Explicit -Sub SeriesSplitIntoBins() +Public Sub ComputeDistanceMatrix() - On Error GoTo ErrorNoSelection +'get the range of inputs, along with input name + Dim rng_input As Range + Set rng_input = Application.InputBox("Select input data", "Input", Type:=8) - Dim rngSelection As Range - Set rngSelection = Application.InputBox("Select category range with heading", _ - Type:=8) - Set rngSelection = Intersect(rngSelection, _ - rngSelection.Parent.UsedRange).SpecialCells(xlCellTypeVisible, xlLogical + _ - xlNumbers + xlTextValues) + 'Dim rng_ID As Range + 'Set rng_ID = Application.InputBox("Select ID data", "ID", Type:=8) - Dim rngValues As Range - Set rngValues = Application.InputBox("Select values range with heading", _ - Type:=8) - Set rngValues = Intersect(rngValues, rngValues.Parent.UsedRange) + 'turning off updates makes a huge difference here... could also use array for output + Application.ScreenUpdating = False + Application.Calculation = xlCalculationManual + Application.EnableEvents = False - ''need to prompt for max/min/bins - Dim dbl_max As Double, dbl_min As Double, int_bins As Integer + 'create new workbook + Dim wkbk As Workbook + Set wkbk = Workbooks.Add - dbl_min = Application.InputBox("Minimum value.", "Min", _ - WorksheetFunction.Min(rngSelection), Type:=1) - dbl_max = Application.InputBox("Maximum value.", "Max", _ - WorksheetFunction.Max(rngSelection), Type:=1) - int_bins = Application.InputBox("Number of groups.", "Bins", _ - WorksheetFunction.RoundDown(Math.Sqr(WorksheetFunction.count(rngSelection)), 0), _ - Type:=1) + Dim sht_out As Worksheet + Set sht_out = wkbk.Sheets(1) + sht_out.name = "scaled data" - On Error GoTo 0 + 'copy data over to standardize + rng_input.Copy wkbk.Sheets(1).Range("A1") - 'determine default value - Dim strDefault As Variant - strDefault = Application.InputBox("Enter the default value", "Default", "#N/A") + 'go to edge of data, add a column, add STANDARDIZE, copy paste values, delete + + Dim rng_data As Range + Set rng_data = sht_out.Range("A1").CurrentRegion + + Dim rng_col As Range + For Each rng_col In rng_data.Columns + + 'edge cell + Dim rng_edge As Range + Set rng_edge = sht_out.Cells(1, sht_out.Columns.count).End(xlToLeft).Offset(, 1) + + 'do a normal dist standardization + '=STANDARDIZE(A1,AVERAGE(A:A),STDEV.S(A:A)) + + rng_edge.Formula = "=IFERROR(STANDARDIZE(" & rng_col.Cells(1, 1).Address(False, False) & ",AVERAGE(" & _ + rng_col.Address & "),STDEV.S(" & rng_col.Address & ")),0)" + + 'do a simple value over average to detect differences + rng_edge.Formula = "=IFERROR(" & rng_col.Cells(1, 1).Address(False, False) & "/AVERAGE(" & _ + rng_col.Address & "),1)" + + 'fill that down + Range(rng_edge, rng_edge.Offset(, -1).End(xlDown).Offset(, 1)).FillDown - 'detect cancel and exit - If StrPtr(strDefault) = 0 Then - Exit Sub - End If + Next + + Application.Calculate + sht_out.UsedRange.Value = sht_out.UsedRange.Value + rng_data.EntireColumn.Delete + + Dim sht_dist As Worksheet + Set sht_dist = wkbk.Worksheets.Add() + sht_dist.name = "distances" - ''TODO prompt for output location + Dim rng_out As Range + Set rng_out = sht_dist.Range("A1") - rngValues.EntireColumn.Offset(, 1).Resize(, int_bins + 2).Insert - 'head the columns with the values + 'loop through each row with each other row + Dim rng_row1 As Range + Dim rng_row2 As Range + + Set rng_input = sht_out.Range("A1").CurrentRegion - ''TODO add a For loop to go through the bins + For Each rng_row1 In rng_input.Rows + For Each rng_row2 In rng_input.Rows - Dim int_binNo As Integer - For int_binNo = 0 To int_bins - rngValues.Cells(1).Offset(, int_binNo + 1) = dbl_min + (dbl_max - dbl_min) * int_binNo / int_bins - Next + 'loop through each column and compute the distance + Dim dbl_dist_sq As Double + dbl_dist_sq = 0 - 'add the last item - rngValues.Cells(1).Offset(, int_bins + 2).FormulaR1C1 = "=RC[-1]" + Dim int_col As Integer + For int_col = 1 To rng_row1.Cells.count + dbl_dist_sq = dbl_dist_sq + (rng_row1.Cells(1, int_col) - rng_row2.Cells(1, int_col)) ^ 2 + Next - ''TODO add formulas for first, mid, last columns - 'FIRST =IF($D2 <=V$1,$U2,#N/A) - '=IF(RC4 <=R1C,RC21,#N/A) + 'take the sqrt of that value and output + rng_out.Value = dbl_dist_sq ^ 0.5 - 'MID =IF(AND($D2 <=W$1, $D2>V$1),$U2,#N/A) '''W current, then left - '=IF(AND(RC4 <=R1C, RC4>R1C[-1]),RC21,#N/A) + 'get to next column for output + Set rng_out = rng_out.Offset(, 1) + Next - 'LAST =IF($D2>AA$1,$U2,#N/A) - '=IF(RC4>R1C[-1],RC21,#N/A) + 'drop down a row and go back to left edge + Set rng_out = rng_out.Offset(1).End(xlToLeft) + Next - ''TODO add number format to display header correctly (helps with charts) + Application.EnableEvents = True + Application.Calculation = xlCalculationAutomatic + Application.ScreenUpdating = True + + sht_dist.UsedRange.NumberFormat = "0.00" + sht_dist.UsedRange.EntireColumn.AutoFit + + 'do the coloring + Formatting_AddCondFormat sht_dist.UsedRange - 'put the formula in for each column - '=IF(RC13=R1C,RC16,#N/A) - Dim strFormula As Variant - strFormula = "=IF(AND(RC" & rngSelection.Column & _ - " <=R" & rngValues.Cells(1).Row & "C," & _ - "RC" & rngSelection.Column & ">R" & rngValues.Cells(1).Row & "C[-1]" & _ - ")" & _ - ",RC" & rngValues.Column & "," & strDefault & ")" +End Sub - Dim str_FirstFormula As Variant - str_FirstFormula = "=IF(AND(RC" & rngSelection.Column & _ - " <=R" & rngValues.Cells(1).Row & "C)" & _ - ",RC" & rngValues.Column & "," & strDefault & ")" +Sub RemoveAllLegends() - Dim str_LastFormula As Variant - str_LastFormula = "=IF(AND(RC" & rngSelection.Column & _ - " >R" & rngValues.Cells(1).Row & "C)" & _ - ",RC" & rngValues.Column & "," & strDefault & ")" + Dim cht_obj As ChartObject + + For Each cht_obj In Chart_GetObjectsFromObject(Selection) + cht_obj.Chart.HasLegend = False + cht_obj.Chart.HasTitle = True + + cht_obj.Chart.SeriesCollection(1).MarkerSize = 4 + Next - Dim rngFormula As Range - Set rngFormula = rngValues.Offset(1, 1).Resize(rngValues.Rows.count - 1, _ - int_bins + 2) - rngFormula.FormulaR1C1 = strFormula +End Sub - 'override with first/last - rngFormula.Columns(1).FormulaR1C1 = str_FirstFormula - rngFormula.Columns(rngFormula.Columns.count).FormulaR1C1 = str_LastFormula +Sub ApplyFormattingToEachColumn() + Dim rng As Range + For Each rng In Selection.Columns + + Formatting_AddCondFormat rng + Next +End Sub + +Private Sub Formatting_AddCondFormat(ByVal rng As Range) + + rng.FormatConditions.AddColorScale ColorScaleType:=3 + rng.FormatConditions(rng.FormatConditions.count).SetFirstPriority + rng.FormatConditions(1).ColorScaleCriteria(1).Type = _ + xlConditionValueLowestValue + With rng.FormatConditions(1).ColorScaleCriteria(1).FormatColor + .Color = 7039480 + .TintAndShade = 0 + End With + rng.FormatConditions(1).ColorScaleCriteria(2).Type = _ + xlConditionValuePercentile + rng.FormatConditions(1).ColorScaleCriteria(2).Value = 50 + With rng.FormatConditions(1).ColorScaleCriteria(2).FormatColor + .Color = 8711167 + .TintAndShade = 0 + End With + rng.FormatConditions(1).ColorScaleCriteria(3).Type = _ + xlConditionValueHighestValue + With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor + .Color = 8109667 + .TintAndShade = 0 + End With +End Sub - rngFormula.EntireColumn.AutoFit - - 'set the number formats - rngFormula.Offset(-1).Rows(1).Resize(1, int_bins + 1).NumberFormat = "<= General" - rngFormula.Offset(-1).Rows(1).Offset(, int_bins + 1).NumberFormat = "> General" - Exit Sub -ErrorNoSelection: - 'TODO: consider removing this prompt - MsgBox "No selection made. Exiting.", , "No selection" +'--------------------------------------------------------------------------------------- +' Procedure : TraceDependentsForAll +' Author : @byronwall +' Date : 2015 11 09 +' Purpose : Quick Sub to iterate through Selection and Trace Dependents for all +'--------------------------------------------------------------------------------------- +' +Sub TraceDependentsForAll() + + Dim rng As Range + + For Each rng In Intersect(Selection, Selection.Parent.UsedRange) + rng.ShowDependents + Next rng End Sub diff --git a/src/code/Usability.bas b/src/code/Usability.bas index b1251d1..faf98c7 100644 --- a/src/code/Usability.bas +++ b/src/code/Usability.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "Usability" +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : Usability ' Author : @byronwall @@ -6,6 +8,78 @@ Attribute VB_Name = "Usability" ' Purpose : Contains an assortment of code that automates some task '--------------------------------------------------------------------------------------- + +Sub CreatePdfOfEachXlsxFileInFolder() + + 'pick a folder + Dim diag_folder As FileDialog + Set diag_folder = Application.FileDialog(msoFileDialogFolderPicker) + + diag_folder.Show + + Dim str_path As String + str_path = diag_folder.SelectedItems(1) & "\" + + 'find all files in the folder + Dim str_file As String + str_file = Dir(str_path & "*.xlsx") + + Do While str_file <> "" + + Dim wkbk_file As Workbook + Set wkbk_file = Workbooks.Open(str_path & str_file, , True) + + Dim sht As Worksheet + + For Each sht In wkbk_file.Worksheets + sht.Range("A16").EntireRow.RowHeight = 15.75 + sht.Range("A17").EntireRow.RowHeight = 15.75 + sht.Range("A22").EntireRow.RowHeight = 15.75 + sht.Range("A23").EntireRow.RowHeight = 15.75 + Next + + wkbk_file.ExportAsFixedFormat xlTypePDF, str_path & str_file & ".pdf" + wkbk_file.Close False + + str_file = Dir + Loop +End Sub + +Sub MakeSeveralBoxesWithNumbers() + + Dim shp As Shape + Dim sht As Worksheet + + Dim rng_loc As Range + Set rng_loc = Application.InputBox("select range", Type:=8) + + Set sht = ActiveSheet + + Dim int_counter As Integer + + For int_counter = 1 To InputBox("How many?") + + Set shp = sht.Shapes.AddTextbox(msoShapeRectangle, rng_loc.left, _ + rng_loc.top + 20 * int_counter, 20, 20) + + shp.Title = int_counter + + shp.Fill.Visible = msoFalse + shp.Line.Visible = msoFalse + + shp.TextFrame2.TextRange.Characters.Text = int_counter + + With shp.TextFrame2.TextRange.Font.Fill + .Visible = msoTrue + .ForeColor.RGB = RGB(0, 0, 0) + .Transparency = 0 + .Solid + End With + + Next + +End Sub + '--------------------------------------------------------------------------------------- ' Procedure : ColorInputs ' Author : @byronwall @@ -134,7 +208,7 @@ End Sub Sub ConvertSelectionToCsv() Dim rngCSV As Range - Set rngCSV = GetInputOrSelection + Set rngCSV = GetInputOrSelection("Choose range for converting to CSV") If rngCSV Is Nothing Then Exit Sub @@ -162,6 +236,27 @@ Sub ConvertSelectionToCsv() End Sub +Public Sub CopyCellAddress() +'--------------------------------------------------------------------------------------- +' Procedure : CopyCellAddress +' Author : @byronwall +' Date : 2015 12 03 +' Purpose : Copies the current cell address to the clipboard for paste use in a formula +'--------------------------------------------------------------------------------------- +' + +'TODO: this need to get a button or a keyboard shortcut for easy use + Dim clipboard As MSForms.DataObject + Set clipboard = New MSForms.DataObject + + Dim rng_sel As Range + Set rng_sel = Selection + + clipboard.SetText rng_sel.Address(True, True, xlA1, True) + clipboard.PutInClipboard +End Sub + + '--------------------------------------------------------------------------------------- ' Procedure : CopyClear ' Author : @byronwall @@ -171,8 +266,12 @@ End Sub ' Sub Sheet_DeleteHiddenRows() 'These rows are unrecoverable + Dim x As VbMsgBoxResult x = MsgBox("This will permanently delete hidden rows. They cannot be recovered. Are you sure?", vbYesNo) - If x = 7 Then Exit Sub + + If Not x = vbYes Then + Exit Sub + End If Application.ScreenUpdating = False @@ -180,6 +279,7 @@ Sub Sheet_DeleteHiddenRows() Dim iCount As Integer iCount = 0 With ActiveSheet + Dim i As Integer For i = .UsedRange.Rows.count To 1 Step -1 If .Rows(i).Hidden Then .Rows(i).Delete @@ -233,6 +333,7 @@ Sub CutPasteTranspose() rngOut.Activate 'Check to not overwrite + Dim c As Range For Each c In rngSelect If Not Intersect(rngSelect, Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow)) Is Nothing Then MsgBox ("Your destination intersects with your data") @@ -240,7 +341,6 @@ Sub CutPasteTranspose() End If Next - Dim c As Range For Each c In rngSelect c.Cut ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).Activate @@ -371,7 +471,7 @@ End Sub Sub FillValueDown() Dim rngInput As Range - Set rngInput = GetInputOrSelection() + Set rngInput = GetInputOrSelection("Select range for waterfall") If rngInput Is Nothing Then Exit Sub @@ -549,6 +649,125 @@ ErrorNoSelection: End Sub +'--------------------------------------------------------------------------------------- +' Procedure : SeriesSplitIntoBins +' Author : @byronwall +' Date : 2015 11 03 +' Purpose : Code will break a column of continuous data into bins for plotting +'--------------------------------------------------------------------------------------- +' +Sub SeriesSplitIntoBins() + + On Error GoTo ErrorNoSelection + + Dim rngSelection As Range + Set rngSelection = Application.InputBox("Select category range with heading", _ + Type:=8) + Set rngSelection = Intersect(rngSelection, _ + rngSelection.Parent.UsedRange).SpecialCells(xlCellTypeVisible, xlLogical + _ + xlNumbers + xlTextValues) + + Dim rngValues As Range + Set rngValues = Application.InputBox("Select values range with heading", _ + Type:=8) + Set rngValues = Intersect(rngValues, rngValues.Parent.UsedRange) + + ''need to prompt for max/min/bins + Dim dbl_max As Double, dbl_min As Double, int_bins As Integer + + dbl_min = Application.InputBox("Minimum value.", "Min", _ + WorksheetFunction.Min(rngSelection), Type:=1) + dbl_max = Application.InputBox("Maximum value.", "Max", _ + WorksheetFunction.Max(rngSelection), Type:=1) + int_bins = Application.InputBox("Number of groups.", "Bins", _ + WorksheetFunction.RoundDown(Math.Sqr(WorksheetFunction.count(rngSelection)), _ + 0), Type:=1) + + On Error GoTo 0 + + 'determine default value + Dim strDefault As Variant + strDefault = Application.InputBox("Enter the default value", "Default", _ + "#N/A") + + 'detect cancel and exit + If StrPtr(strDefault) = 0 Then + Exit Sub + End If + + ''TODO prompt for output location + + rngValues.EntireColumn.Offset(, 1).Resize(, int_bins + 2).Insert + 'head the columns with the values + + ''TODO add a For loop to go through the bins + + Dim int_binNo As Integer + For int_binNo = 0 To int_bins + rngValues.Cells(1).Offset(, int_binNo + 1) = dbl_min + (dbl_max - _ + dbl_min) * int_binNo / int_bins + Next + + 'add the last item + rngValues.Cells(1).Offset(, int_bins + 2).FormulaR1C1 = "=RC[-1]" + + 'FIRST =IF($D2 <=V$1,$U2,#N/A) + '=IF(RC4 <=R1C,RC21,#N/A) + + 'MID =IF(AND($D2 <=W$1, $D2>V$1),$U2,#N/A) '''W current, then left + '=IF(AND(RC4 <=R1C, RC4>R1C[-1]),RC21,#N/A) + + 'LAST =IF($D2>AA$1,$U2,#N/A) + '=IF(RC4>R1C[-1],RC21,#N/A) + + ''TODO add number format to display header correctly (helps with charts) + + 'put the formula in for each column + '=IF(RC13=R1C,RC16,#N/A) + Dim strFormula As Variant + strFormula = "=IF(AND(RC" & rngSelection.Column & " <=R" & _ + rngValues.Cells(1).Row & "C," & "RC" & rngSelection.Column & ">R" & _ + rngValues.Cells(1).Row & "C[-1]" & ")" & ",RC" & rngValues.Column & "," & _ + strDefault & ")" + + Dim str_FirstFormula As Variant + str_FirstFormula = "=IF(AND(RC" & rngSelection.Column & " <=R" & _ + rngValues.Cells(1).Row & "C)" & ",RC" & rngValues.Column & "," & strDefault _ + & ")" + + Dim str_LastFormula As Variant + str_LastFormula = "=IF(AND(RC" & rngSelection.Column & " >R" & _ + rngValues.Cells(1).Row & "C)" & ",RC" & rngValues.Column & "," & strDefault _ + & ")" + + Dim rngFormula As Range + Set rngFormula = rngValues.Offset(1, 1).Resize(rngValues.Rows.count - 1, _ + int_bins + 2) + rngFormula.FormulaR1C1 = strFormula + + 'override with first/last + rngFormula.Columns(1).FormulaR1C1 = str_FirstFormula + rngFormula.Columns(rngFormula.Columns.count).FormulaR1C1 = str_LastFormula + + rngFormula.EntireColumn.AutoFit + + 'set the number formats + rngFormula.Offset(-1).Rows(1).Resize(1, int_bins + 1).NumberFormat = _ + "<= General" + rngFormula.Offset(-1).Rows(1).Offset(, int_bins + 1).NumberFormat = _ + "> General" + + Exit Sub + +ErrorNoSelection: + 'TODO: consider removing this prompt + MsgBox "No selection made. Exiting.", , "No selection" + +End Sub + + + + '--------------------------------------------------------------------------------------- ' Procedure : Sht_DeleteHiddenRows ' Author : @byronwall @@ -561,6 +780,7 @@ Sub Sht_DeleteHiddenRows() Application.ScreenUpdating = False Dim Row As Range + Dim i As Integer For i = ActiveSheet.UsedRange.Rows.count To 1 Step -1 diff --git a/src/code/bUTLChartSeries.cls b/src/code/bUTLChartSeries.cls index 38c95ff..ad055da 100644 --- a/src/code/bUTLChartSeries.cls +++ b/src/code/bUTLChartSeries.cls @@ -7,6 +7,8 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False +Option Explicit + '--------------------------------------------------------------------------------------- ' Module : bUTLChartSeries ' Author : @byronwall @@ -21,6 +23,8 @@ Public SeriesNumber As Integer Public ChartType As XlChartType Public series As series +Private str_name As String + '--------------------------------------------------------------------------------------- ' Procedure : AddSeriesToChart ' Author : @byronwall @@ -69,8 +73,18 @@ End Function '--------------------------------------------------------------------------------------- ' Public Property Get SeriesFormula() As String - - SeriesFormula = "=SERIES(" & FullAddress(Me.name) & "," & FullAddress(Me.XValues) & "," & FullAddress(Me.Values) & "," & Me.SeriesNumber & ")" + + '2015 11 09 add a trap here to allow for a string only name + If str_name <> "" Then + SeriesFormula = "=SERIES(" & str_name & "," & _ + FullAddress(Me.XValues) & "," & FullAddress(Me.Values) & "," & _ + Me.SeriesNumber & ")" + Else + + SeriesFormula = "=SERIES(" & FullAddress(Me.name) & "," & _ + FullAddress(Me.XValues) & "," & FullAddress(Me.Values) & "," & _ + Me.SeriesNumber & ")" + End If End Property @@ -88,74 +102,63 @@ End Sub '--------------------------------------------------------------------------------------- ' Procedure : UpdateFromChartSeries ' Author : @byronwall -' Date : 2015 07 24 +' Date : 2015 11 09 ' Purpose : Reads the series info from a Series and stores it in the class '--------------------------------------------------------------------------------------- ' Sub UpdateFromChartSeries(ser As series) - 'this will work for the simple case where all items are references - +'this will work for the simple case where all items are references + Set series = ser Dim form As Variant - - ' "=SERIES("Y",Sheet1!$C$8:$C$13,Sheet1!$D$8:$D$13,1)" - + + '=SERIES("Y",Sheet1!$C$8:$C$13,Sheet1!$D$8:$D$13,1) + 'pull in teh formula form = ser.Formula - + 'uppercase to remove match errors form = UCase(form) - + 'remove the front of the formula form = Replace(form, "=SERIES(", "") - - 'Debug.Print form & vbCrLf - ' "Y",SHEET1!$C$8:$C$13,SHEET1!$D$8:$D$13,1) - + 'find the first comma Dim comma comma = InStr(form, ",") - - 'Debug.Print comma - + If comma > 1 Then - Set Me.name = Range(left(form, comma - 1)) + + 'need to catch an error here if a text name is used instead of a valid range + On Error Resume Next + Set Me.name = Range(left(form, comma - 1)) + + If Err <> 0 Then + str_name = left(form, comma - 1) + End If + + On Error GoTo 0 End If - + 'pull out the title from that form = Mid(form, comma + 1) - - 'Debug.Print vbCrLf & form - ' SHEET1!$C$8:$C$13,SHEET1!$D$8:$D$13,1) - - 'check the xvalues for multiple references (include paren) - + comma = InStr(form, ",") - + If comma > 1 Then - Set Me.XValues = Range(left(form, comma - 1)) + Set Me.XValues = Range(left(form, comma - 1)) End If form = Mid(form, comma + 1) - 'Debug.Print vbCrLf & form - + comma = InStr(form, ",") Set Me.Values = Range(left(form, comma - 1)) form = Mid(form, comma + 1) - 'Debug.Print vbCrLf & form - + comma = InStr(form, ")") Me.SeriesNumber = left(form, comma - 1) - + Me.ChartType = ser.ChartType - - 'if parenth then bring in until ), // otherwise until next comma - - 'do teh same thing for y values - - 'pull in the series number - - End Sub '--------------------------------------------------------------------------------------- diff --git a/src/code/form_chtSeries.frm b/src/code/form_chtSeries.frm index 6a90106..3e14b9e 100644 --- a/src/code/form_chtSeries.frm +++ b/src/code/form_chtSeries.frm @@ -14,10 +14,7 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False - - - - +Option Explicit '--------------------------------------------------------------------------------------- ' Module : form_chtSeries diff --git a/src/code/form_chtSeries.frx b/src/code/form_chtSeries.frx index ae27183..658f2cd 100644 Binary files a/src/code/form_chtSeries.frx and b/src/code/form_chtSeries.frx differ diff --git a/src/code/form_newCommands.frm b/src/code/form_newCommands.frm index 95f10f3..f9ab8f7 100644 --- a/src/code/form_newCommands.frm +++ b/src/code/form_newCommands.frm @@ -1,11 +1,12 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} form_newCommands Caption = "Additional Features" - ClientHeight = 5970 + ClientHeight = 8460 ClientLeft = 45 ClientTop = 435 ClientWidth = 6585 OleObjectBlob = "form_newCommands.frx":0000 + ShowModal = 0 'False StartUpPosition = 1 'CenterOwner End Attribute VB_Name = "form_newCommands" @@ -14,10 +15,7 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False - - - - +Option Explicit '--------------------------------------------------------------------------------------- ' Module : form_newCommands @@ -25,12 +23,9 @@ Attribute VB_Exposed = False ' Date : 2015 07 24 ' Purpose : This form is just buttons to easier get to new code '--------------------------------------------------------------------------------------- -Option Explicit Private Sub CommandButton1_Click() - Chart_CreateDataLabels - End Sub Private Sub CommandButton13_Click() @@ -84,3 +79,26 @@ Private Sub CommandButton26_Click() GenerateRandomData End Sub +Private Sub CommandButton27_Click() + SeriesSplitIntoBins +End Sub + +Private Sub CommandButton28_Click() + Chart_SortSeriesByName +End Sub + +Private Sub CommandButton29_Click() + CreatePdfOfEachXlsxFileInFolder +End Sub + +Private Sub CommandButton30_Click() + ApplyFormattingToEachColumn +End Sub + +Private Sub CommandButton31_Click() + ComputeDistanceMatrix +End Sub + +Private Sub CommandButton32_Click() + Chart_CreateChartWithSeriesForEachColumn +End Sub diff --git a/src/code/form_newCommands.frx b/src/code/form_newCommands.frx index 3d9480e..1b966ac 100644 Binary files a/src/code/form_newCommands.frx and b/src/code/form_newCommands.frx differ diff --git a/src/package/xl/vbaProject.bin b/src/package/xl/vbaProject.bin index 1af058d..9912d7f 100644 Binary files a/src/package/xl/vbaProject.bin and b/src/package/xl/vbaProject.bin differ