diff --git a/README.md b/README.md index dbc3652..06640bd 100644 --- a/README.md +++ b/README.md @@ -20,3 +20,14 @@ If you want to contribute a feature to the add-in or improve the code in some ot - commit and submit a pull request Why? This workflow has been adopted because Excel/VBA files have severe limitations for version control. An `xlam` file is a zipped folder with a number of binary files inside the zip. There are a couple of useful add-ins which help manage this, but I would prefer to not dictate what add-ins are installed. Given that, this workflow and build scripts allow for changes to the underlying VBA code and Ribbon interface to be properly tracked. + +##Structure of the repo +The repo contains the source code, documentation, and several scripts used to generate the source from the xlam file. + +Folder structure: + + - docs: contains Markdown files to explain the functions of the add-in + - scripts: contains the build scripts which are used to convert the xlam file to repo-ready source code and to convert the source code to a usable xlam file. + - src: this folders contains the actual source code including an unzipped version of the xlam file + - code: this folder contains .bas, .cls, and .frx files which represent the source of the VBA code + - package: this is an unzipped version of the xlam file which allows for the XML driving the add-in to be tracked correctly \ No newline at end of file diff --git a/bUTL.xlam b/bUTL.xlam deleted file mode 100644 index 76e3c3b..0000000 Binary files a/bUTL.xlam and /dev/null differ diff --git a/src/code/Chart_Axes.bas b/src/code/Chart_Axes.bas index 9919b49..d26d7fe 100644 --- a/src/code/Chart_Axes.bas +++ b/src/code/Chart_Axes.bas @@ -1,31 +1,21 @@ Attribute VB_Name = "Chart_Axes" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Chart_Axes -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains code related to chart axes -'--------------------------------------------------------------------------------------- - -'--------------------------------------------------------------------------------------- -' Procedure : Chart_Axis_AutoX -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Reverts the x axis of a chart back to Auto -'--------------------------------------------------------------------------------------- -' Sub Chart_Axis_AutoX() - + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_Axis_AutoX + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Reverts the x axis of a chart back to Auto + '--------------------------------------------------------------------------------------- + ' Dim chartObj As ChartObject For Each chartObj In Chart_GetObjectsFromObject(Selection) - Dim myChart As Chart - + Dim cht As Chart + Set cht = chartObj.Chart + Dim xAxis As Axis - - Set myChart = chartObj.Chart - - Set xAxis = myChart.Axes(xlCategory) + Set xAxis = cht.Axes(xlCategory) xAxis.MaximumScaleIsAuto = True xAxis.MinimumScaleIsAuto = True xAxis.MajorUnitIsAuto = True @@ -35,24 +25,22 @@ Sub Chart_Axis_AutoX() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_Axis_AutoY -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Reverts the Y axis of a chart back to Auto -'--------------------------------------------------------------------------------------- -' -Sub Chart_Axis_AutoY() +Sub Chart_Axis_AutoY() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_Axis_AutoY + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Reverts the Y axis of a chart back to Auto + '--------------------------------------------------------------------------------------- + ' Dim chartObj As ChartObject For Each chartObj In Chart_GetObjectsFromObject(Selection) - Dim myChart As Chart - + Dim cht As Chart + Set cht = chartObj.Chart + Dim yAxis As Axis - - Set myChart = chartObj.Chart - - Set yAxis = myChart.Axes(xlValue) + Set yAxis = cht.Axes(xlValue) yAxis.MaximumScaleIsAuto = True yAxis.MinimumScaleIsAuto = True yAxis.MajorUnitIsAuto = True @@ -62,92 +50,92 @@ Sub Chart_Axis_AutoY() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_FitAxisToMaxAndMin -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Iterates through all series and sets desired axis to max/min of data -'--------------------------------------------------------------------------------------- -' -Sub Chart_FitAxisToMaxAndMin(typeOfAxis As XlAxisType) + +Sub Chart_FitAxisToMaxAndMin(axisType As XlAxisType) + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_FitAxisToMaxAndMin + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Iterates through all series and sets desired axis to max/min of data + '--------------------------------------------------------------------------------------- + ' Dim chartObj As ChartObject For Each chartObj 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 isFirst As Boolean + isFirst = True - Dim myChart As Chart - Set myChart = chartObj.Chart + Dim cht As Chart + Set cht = chartObj.Chart - Dim mySeries As series - For Each mySeries In myChart.SeriesCollection + Dim chtSeries As series + For Each chtSeries In cht.SeriesCollection - Dim minimumValue As Double - Dim maximumValue As Double + Dim minValue As Double + Dim maxValue As Double - If typeOfAxis = xlCategory Then + If axisType = xlCategory Then - minimumValue = Application.Min(mySeries.XValues) - maximumValue = Application.Max(mySeries.XValues) + minValue = Application.Min(chtSeries.XValues) + maxValue = Application.Max(chtSeries.XValues) - ElseIf typeOfAxis = xlValue Then + ElseIf axisType = xlValue Then - minimumValue = Application.Min(mySeries.Values) - maximumValue = Application.Max(mySeries.Values) + minValue = Application.Min(chtSeries.Values) + maxValue = Application.Max(chtSeries.Values) End If - Dim myAxis As Axis - Set myAxis = myChart.Axes(typeOfAxis) + Dim ax As Axis + Set ax = cht.Axes(axisType) - Dim newMinimum As Boolean - Dim newMaximum As Boolean - - newMaximum = maximumValue > myAxis.MaximumScale - newMinimum = minimumValue < myAxis.MinimumScale + Dim isNewMax As Boolean, isNewMin As Boolean + isNewMax = maxValue > ax.MaximumScale + isNewMin = minValue < ax.MinimumScale - If first Or newMinimum Then - myAxis.MinimumScale = minimumValue + If isFirst Or isNewMin Then + ax.MinimumScale = minValue End If - If first Or newMaximum Then - myAxis.MaximumScale = maximumValue + If isFirst Or isNewMax Then + ax.MaximumScale = maxValue End If - first = False - Next mySeries + isFirst = False + Next chtSeries Next chartObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_YAxisRangeWithAvgAndStdev -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Sets a chart's Y axis to a number of standard deviations -' Flags : not-used -'--------------------------------------------------------------------------------------- -' -Public Sub Chart_YAxisRangeWithAvgAndStdev() - Dim numberStandardDeviations As Double - numberStandardDeviations = CDbl(InputBox("How many standard deviations to include?")) +Public Sub Chart_YAxisRangeWithAvgAndStdev() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_YAxisRangeWithAvgAndStdev + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Sets a chart's Y axis to a number of standard deviations + ' Flags : not-used + '--------------------------------------------------------------------------------------- + ' + Dim numberOfStdDevs As Double + + numberOfStdDevs = CDbl(InputBox("How many standard deviations to include?")) Dim chartObj As ChartObject For Each chartObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series - Set mySeries = chartObj.Chart.SeriesCollection(1) + Dim chtSeries As series + Set chtSeries = chartObj.Chart.SeriesCollection(1) - Dim averageValue As Double - Dim standardValue As Double + Dim avgValue As Double + Dim stdValue As Double - averageValue = WorksheetFunction.Average(mySeries.Values) - standardValue = WorksheetFunction.StDev(mySeries.Values) + avgValue = WorksheetFunction.Average(chtSeries.Values) + stdValue = WorksheetFunction.StDev(chtSeries.Values) - chartObj.Chart.Axes(xlValue).MinimumScale = averageValue - standardValue * numberStandardDeviations - chartObj.Chart.Axes(xlValue).MaximumScale = averageValue + standardValue * numberStandardDeviations + chartObj.Chart.Axes(xlValue).MinimumScale = avgValue - stdValue * numberOfStdDevs + chartObj.Chart.Axes(xlValue).MaximumScale = avgValue + stdValue * numberOfStdDevs Next diff --git a/src/code/Chart_Format.bas b/src/code/Chart_Format.bas index e6d9eed..d821a22 100644 --- a/src/code/Chart_Format.bas +++ b/src/code/Chart_Format.bas @@ -1,157 +1,161 @@ Attribute VB_Name = "Chart_Format" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Chart_Format -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains code related to formatting charts -'--------------------------------------------------------------------------------------- - - -'--------------------------------------------------------------------------------------- -' Procedure : Chart_AddTitles -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Adds all missing titles to all selected charts -'--------------------------------------------------------------------------------------- -' -Sub Chart_AddTitles() - Dim myChartObject As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) +Sub Chart_AddTitles() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_AddTitles + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Adds all missing titles to all selected charts + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + + For Each chtObj In Chart_GetObjectsFromObject(Selection) + + If Not chtObj.Chart.Axes(xlCategory).HasTitle Then + chtObj.Chart.Axes(xlCategory).HasTitle = True + chtObj.Chart.Axes(xlCategory).AxisTitle.Text = "x axis" + End If - If Not myChartObject.Chart.Axes(xlCategory).HasTitle Then - myChartObject.Chart.Axes(xlCategory).HasTitle = True - myChartObject.Chart.Axes(xlCategory).AxisTitle.Text = "x axis" + If Not chtObj.Chart.Axes(xlValue, xlPrimary).HasTitle Then + chtObj.Chart.Axes(xlValue).HasTitle = True + chtObj.Chart.Axes(xlValue).AxisTitle.Text = "y axis" End If - If Not myChartObject.Chart.Axes(xlValue).HasTitle Then - myChartObject.Chart.Axes(xlValue).HasTitle = True - myChartObject.Chart.Axes(xlValue).AxisTitle.Text = "y axis" + '2015 12 14, add support for 2nd y axis + If chtObj.Chart.Axes.count = 3 Then + If Not chtObj.Chart.Axes(xlValue, xlSecondary).HasTitle Then + chtObj.Chart.Axes(xlValue, xlSecondary).HasTitle = True + chtObj.Chart.Axes(xlValue, xlSecondary).AxisTitle.Text = "2nd y axis" + End If End If - If Not myChartObject.Chart.HasTitle Then - myChartObject.Chart.HasTitle = True - myChartObject.Chart.ChartTitle.Text = "chart" + If Not chtObj.Chart.HasTitle Then + chtObj.Chart.HasTitle = True + chtObj.Chart.ChartTitle.Text = "chart" End If Next End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_ApplyFormattingToSelected -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Applies a semi-random format to all charts -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub Chart_ApplyFormattingToSelected() - Dim myChart As ChartObject +Sub Chart_ApplyFormattingToSelected() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_ApplyFormattingToSelected + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Applies a semi-random format to all charts + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject - For Each myChart In Chart_GetObjectsFromObject(Selection) + For Each chtObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series + Dim chtSeries As series - For Each mySeries In myChart.Chart.SeriesCollection - mySeries.MarkerSize = 5 - Next mySeries - Next myChart + For Each chtSeries In chtObj.Chart.SeriesCollection + chtSeries.MarkerSize = 5 + Next chtSeries + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_ApplyTrendColors -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Applies the predetermined chart colors to each series -'--------------------------------------------------------------------------------------- -' -Sub Chart_ApplyTrendColors() - Dim myChartObject As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) +Sub Chart_ApplyTrendColors() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_ApplyTrendColors + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Applies the predetermined chart colors to each series + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + For Each chtObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series - For Each mySeries In myChartObject.Chart.SeriesCollection + Dim chtSeries As series + For Each chtSeries In chtObj.Chart.SeriesCollection - Dim ButlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries + Dim butlSeries As New bUTLChartSeries + butlSeries.UpdateFromChartSeries chtSeries - mySeries.MarkerForegroundColorIndex = xlColorIndexNone - mySeries.MarkerBackgroundColor = Chart_GetColor(ButlSeries.SeriesNumber) + chtSeries.MarkerForegroundColorIndex = xlColorIndexNone + chtSeries.MarkerBackgroundColor = Chart_GetColor(butlSeries.SeriesNumber) - mySeries.Format.Line.ForeColor.RGB = mySeries.MarkerBackgroundColor + chtSeries.Format.Line.ForeColor.RGB = chtSeries.MarkerBackgroundColor - Next mySeries - Next myChartObject + Next chtSeries + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_AxisTitleIsSeriesTitle -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Sets the y axis title equal to the series name of the last series -'--------------------------------------------------------------------------------------- -' -Sub Chart_AxisTitleIsSeriesTitle() - Dim myChartObject As ChartObject - Dim myChart As Chart - For Each myChartObject In Chart_GetObjectsFromObject(Selection) - Set myChart = myChartObject.Chart - - Dim ButlSeries As bUTLChartSeries - Dim mySeries As series - - For Each mySeries In myChart.SeriesCollection - Set ButlSeries = New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries +Sub Chart_AxisTitleIsSeriesTitle() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_AxisTitleIsSeriesTitle + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Sets the y axis title equal to the series name of the last series + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + Dim cht As Chart + For Each chtObj In Chart_GetObjectsFromObject(Selection) + Set cht = chtObj.Chart + + Dim butlSeries As bUTLChartSeries + Dim chtSeries As series + + For Each chtSeries In cht.SeriesCollection + Set butlSeries = New bUTLChartSeries + butlSeries.UpdateFromChartSeries chtSeries + + cht.Axes(xlValue, chtSeries.AxisGroup).HasTitle = True + cht.Axes(xlValue, chtSeries.AxisGroup).AxisTitle.Text = butlSeries.name - myChart.Axes(xlValue, mySeries.AxisGroup).HasTitle = True - myChart.Axes(xlValue, mySeries.AxisGroup).AxisTitle.Text = ButlSeries.name - '2015 11 11, adds the x-title assuming that the name is one cell above the data - myChart.Axes(xlCategory).HasTitle = True - myChart.Axes(xlCategory).AxisTitle.Text = ButlSeries.XValues.Cells(1, 1).Offset(-1).Value + '2015 12 14, add a check to ensure that the XValue exists + If Not butlSeries.XValues Is Nothing Then + cht.Axes(xlCategory).HasTitle = True + cht.Axes(xlCategory).AxisTitle.Text = butlSeries.XValues.Cells(1, 1).Offset(-1).Value + End If - Next mySeries - Next myChartObject + Next chtSeries + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_CreateDataLabels -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Adds a data label for each series in the chart -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub Chart_CreateDataLabels() - Dim myChartObject As ChartObject +Sub Chart_CreateDataLabels() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_CreateDataLabels + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Adds a data label for each series in the chart + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject On Error GoTo Chart_CreateDataLabels_Error - For Each myChartObject In Chart_GetObjectsFromObject(Selection) + For Each chtObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series - For Each mySeries In myChartObject.Chart.SeriesCollection + Dim chtSeries As series + For Each chtSeries In chtObj.Chart.SeriesCollection - Dim myPoint As Point - Set myPoint = mySeries.Points(2) + Dim dataPoint As Point + Set dataPoint = chtSeries.Points(2) - myPoint.HasDataLabel = False - myPoint.DataLabel.Position = xlLabelPositionRight - myPoint.DataLabel.ShowSeriesName = True - myPoint.DataLabel.ShowValue = False - myPoint.DataLabel.ShowCategoryName = False - myPoint.DataLabel.ShowLegendKey = True + dataPoint.HasDataLabel = False + dataPoint.DataLabel.Position = xlLabelPositionRight + dataPoint.DataLabel.ShowSeriesName = True + dataPoint.DataLabel.ShowValue = False + dataPoint.DataLabel.ShowCategoryName = False + dataPoint.DataLabel.ShowLegendKey = True - Next mySeries - Next myChartObject + Next chtSeries + Next chtObj On Error GoTo 0 Exit Sub @@ -163,167 +167,167 @@ Chart_CreateDataLabels_Error: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_GridOfCharts -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Creates a grid of charts. Used by the form. -'--------------------------------------------------------------------------------------- -' -Sub Chart_GridOfCharts( _ - Optional chartColumns As Long = 3, _ - Optional chartWidth As Double = 400, _ - Optional chartHeight As Double = 300, _ - Optional verticalDisplacement As Double = 80, _ - Optional horizontalDisplacement As Double = 40, _ - Optional checkDown As Boolean = False, _ - Optional isZoom As Boolean = False) - - Dim myChartObject As ChartObject - Dim mySheet As Worksheet - Set mySheet = ActiveSheet +Sub Chart_GridOfCharts( _ + Optional columnCount As Long = 3, _ + Optional chtWidth As Double = 400, _ + Optional chtHeight As Double = 300, _ + Optional offsetVertical As Double = 80, _ + Optional offsetHorizontal As Double = 40, _ + Optional shouldFillDownFirst As Boolean = False, _ + Optional shouldZoomOnGrid As Boolean = False) + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_GridOfCharts + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Creates a grid of charts. Used by the form. + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + + Dim sht As Worksheet + Set sht = ActiveSheet Application.ScreenUpdating = False - Dim count As Long - count = 0 + Dim chtCount As Long + chtCount = 0 - For Each myChartObject In mySheet.ChartObjects - Dim leftSide As Double, topSide As Double + For Each chtObj In sht.ChartObjects + Dim left As Double, top As Double - If checkDown Then - leftSide = (count \ chartColumns) * chartWidth + horizontalDisplacement - topSide = (count Mod chartColumns) * chartHeight + verticalDisplacement + If shouldFillDownFirst Then + left = (chtCount \ columnCount) * chtWidth + offsetHorizontal + top = (chtCount Mod columnCount) * chtHeight + offsetVertical Else - leftSide = (count Mod chartColumns) * chartWidth + horizontalDisplacement - topSide = (count \ chartColumns) * chartHeight + verticalDisplacement + left = (chtCount Mod columnCount) * chtWidth + offsetHorizontal + top = (chtCount \ columnCount) * chtHeight + offsetVertical End If - myChartObject.top = topSide - myChartObject.left = leftSide - myChartObject.Width = chartWidth - myChartObject.Height = chartHeight + chtObj.top = top + chtObj.left = left + chtObj.Width = chtWidth + chtObj.Height = chtHeight - count = count + 1 + chtCount = chtCount + 1 - Next myChartObject + Next chtObj 'loop through columsn to find how far to zoom - If isZoom Then - Dim ColumnZoom As Long - ColumnZoom = 1 - Do While mySheet.Cells(1, ColumnZoom).left < chartColumns * chartWidth - ColumnZoom = ColumnZoom + 1 + If shouldZoomOnGrid Then + Dim columnToZoomTo As Long + columnToZoomTo = 1 + Do While sht.Cells(1, columnToZoomTo).left < columnCount * chtWidth + columnToZoomTo = columnToZoomTo + 1 Loop - mySheet.Range("A:A", mySheet.Cells(1, ColumnZoom - 1).EntireColumn).Select + sht.Range("A:A", sht.Cells(1, columnToZoomTo - 1).EntireColumn).Select ActiveWindow.Zoom = True - mySheet.Range("A1").Select + sht.Range("A1").Select End If Application.ScreenUpdating = True End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartApplyToAll -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Forces all charts to be a XYScatter type -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub ChartApplyToAll() - Dim myChartObject As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) - myChartObject.Chart.SeriesCollection(1).ChartType = xlXYScatter - Next myChartObject +Sub ChartApplyToAll() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartApplyToAll + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Forces all charts to be a XYScatter type + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + For Each chtObj In Chart_GetObjectsFromObject(Selection) + chtObj.Chart.SeriesCollection(1).ChartType = xlXYScatter + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartCreateXYGrid -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Creates a matrix of charts similar to pairs in R -'--------------------------------------------------------------------------------------- -' -Sub ChartCreateXYGrid() +Sub ChartCreateXYGrid() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartCreateXYGrid + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Creates a matrix of charts similar to pairs in R + '--------------------------------------------------------------------------------------- + ' On Error GoTo ChartCreateXYGrid_Error DeleteAllCharts - 'dataRange will contain the block of data with titles included + 'rng_data will contain the block of data with titles included - Dim dataRange As Range - Set dataRange = Application.InputBox("Select data with titles", Type:=8) + Dim rngData As Range + Set rngData = Application.InputBox("Select data with titles", Type:=8) Application.ScreenUpdating = False - Dim iRow As Long, iCol As Long - iRow = 0 + Dim rowIndex As Long, columnIndex As Long + rowIndex = 0 - Dim myHeight As Double, myWidth As Double - myHeight = 300 - myWidth = 400 + Dim chtHeight As Double, chtWidth As Double + chtHeight = 300 + chtWidth = 400 - Dim xColumnData As Range, yColumnData As Range - For Each yColumnData In dataRange.Columns - iCol = 0 + Dim rngColXData As Range, rngColYData As Range + For Each rngColYData In rngData.Columns + columnIndex = 0 - For Each xColumnData In dataRange.Columns - If iRow <> iCol Then - Dim newChart As Chart - Set newChart = ActiveSheet.ChartObjects.Add(iCol * myWidth, _ - iRow * myHeight + 100, _ - myWidth, _ - myHeight).Chart + For Each rngColXData In rngData.Columns + If rowIndex <> columnIndex Then + Dim cht As Chart + Set cht = ActiveSheet.ChartObjects.Add(columnIndex * chtWidth, _ + rowIndex * chtHeight + 100, _ + chtWidth, _ + chtHeight).Chart - Dim mySeries As series - Dim ButlSeries As New bUTLChartSeries + Dim chtSeries As series + Dim butlSeries As New bUTLChartSeries 'offset allows for the title to be excluded - Set ButlSeries.XValues = Intersect(xColumnData, xColumnData.Offset(1)) - Set ButlSeries.Values = Intersect(yColumnData, yColumnData.Offset(1)) - Set ButlSeries.name = yColumnData.Cells(1) - ButlSeries.ChartType = xlXYScatter - - Set mySeries = ButlSeries.AddSeriesToChart(newChart) - - mySeries.MarkerSize = 3 - mySeries.MarkerStyle = xlMarkerStyleCircle - - Dim newAxis As Axis - Set newAxis = newChart.Axes(xlCategory) - newAxis.HasTitle = True - newAxis.AxisTitle.Text = xColumnData.Cells(1) - newAxis.MajorGridlines.Border.Color = RGB(200, 200, 200) - newAxis.MinorGridlines.Border.Color = RGB(220, 220, 220) - - Set newAxis = newChart.Axes(xlValue) - newAxis.HasTitle = True - newAxis.AxisTitle.Text = yColumnData.Cells(1) - newAxis.MajorGridlines.Border.Color = RGB(200, 200, 200) - newAxis.MinorGridlines.Border.Color = RGB(220, 220, 220) - - newChart.HasTitle = True - newChart.ChartTitle.Text = yColumnData.Cells(1) & " vs. " & xColumnData.Cells(1) - 'newChart.ChartTitle.Characters.Font.Size = 8 - newChart.Legend.Delete + Set butlSeries.XValues = Intersect(rngColXData, rngColXData.Offset(1)) + Set butlSeries.Values = Intersect(rngColYData, rngColYData.Offset(1)) + Set butlSeries.name = rngColYData.Cells(1) + butlSeries.ChartType = xlXYScatter + + Set chtSeries = butlSeries.AddSeriesToChart(cht) + + chtSeries.MarkerSize = 3 + chtSeries.MarkerStyle = xlMarkerStyleCircle + + Dim chtAxis As Axis + Set chtAxis = cht.Axes(xlCategory) + chtAxis.HasTitle = True + chtAxis.AxisTitle.Text = rngColXData.Cells(1) + chtAxis.MajorGridlines.Border.Color = RGB(200, 200, 200) + chtAxis.MinorGridlines.Border.Color = RGB(220, 220, 220) + + Set chtAxis = cht.Axes(xlValue) + chtAxis.HasTitle = True + chtAxis.AxisTitle.Text = rngColYData.Cells(1) + chtAxis.MajorGridlines.Border.Color = RGB(200, 200, 200) + chtAxis.MinorGridlines.Border.Color = RGB(220, 220, 220) + + cht.HasTitle = True + cht.ChartTitle.Text = rngColYData.Cells(1) & " vs. " & rngColXData.Cells(1) + 'cht.ChartTitle.Characters.Font.Size = 8 + cht.Legend.Delete End If - iCol = iCol + 1 + columnIndex = columnIndex + 1 Next - iRow = iRow + 1 + rowIndex = rowIndex + 1 Next Application.ScreenUpdating = True - dataRange.Cells(1, 1).Activate + rngData.Cells(1, 1).Activate On Error GoTo 0 Exit Sub @@ -336,100 +340,98 @@ ChartCreateXYGrid_Error: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartDefaultFormat -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Set the default format for all charts on ActiveSheet -'--------------------------------------------------------------------------------------- -' -Sub ChartDefaultFormat() - Dim myChartObject As ChartObject +Sub ChartDefaultFormat() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartDefaultFormat + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Set the default format for all charts on ActiveSheet + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) - Dim newChart As Chart + For Each chtObj In Chart_GetObjectsFromObject(Selection) + Dim cht As Chart - Set newChart = myChartObject.Chart + Set cht = chtObj.Chart - Dim mySeries As series - For Each mySeries In newChart.SeriesCollection + Dim chtSeries As series + For Each chtSeries In cht.SeriesCollection - mySeries.MarkerSize = 3 - mySeries.MarkerStyle = xlMarkerStyleCircle + chtSeries.MarkerSize = 3 + chtSeries.MarkerStyle = xlMarkerStyleCircle - If mySeries.ChartType = xlXYScatterLines Then - mySeries.Format.Line.Weight = 1.5 + If chtSeries.ChartType = xlXYScatterLines Then + chtSeries.Format.Line.Weight = 1.5 End If - mySeries.MarkerForegroundColorIndex = xlColorIndexNone - mySeries.MarkerBackgroundColorIndex = xlColorIndexAutomatic + chtSeries.MarkerForegroundColorIndex = xlColorIndexNone + chtSeries.MarkerBackgroundColorIndex = xlColorIndexAutomatic - Next mySeries + Next chtSeries - newChart.HasLegend = True - newChart.Legend.Position = xlLegendPositionBottom + cht.HasLegend = True + cht.Legend.Position = xlLegendPositionBottom - Dim myAxis As Axis - Set myAxis = newChart.Axes(xlValue) + Dim chtAxis As Axis + Set chtAxis = cht.Axes(xlValue) - myAxis.MajorGridlines.Border.Color = RGB(242, 242, 242) - myAxis.Crosses = xlAxisCrossesMinimum + chtAxis.MajorGridlines.Border.Color = RGB(242, 242, 242) + chtAxis.Crosses = xlAxisCrossesMinimum - Set myAxis = newChart.Axes(xlCategory) + Set chtAxis = cht.Axes(xlCategory) - myAxis.HasMajorGridlines = True + chtAxis.HasMajorGridlines = True - myAxis.MajorGridlines.Border.Color = RGB(242, 242, 242) + chtAxis.MajorGridlines.Border.Color = RGB(242, 242, 242) - If newChart.HasTitle Then - newChart.ChartTitle.Characters.Font.Size = 12 - newChart.ChartTitle.Characters.Font.Bold = True + If cht.HasTitle Then + cht.ChartTitle.Characters.Font.Size = 12 + cht.ChartTitle.Characters.Font.Bold = True End If - Set myAxis = newChart.Axes(xlCategory) + Set chtAxis = cht.Axes(xlCategory) - Next myChartObject + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartPropMove -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Sets the "move or size" setting for all charts -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub ChartPropMove() - - Dim chartObj As ChartObject - For Each chartObj In Chart_GetObjectsFromObject(Selection) - chartObj.Placement = xlFreeFloating - Next chartObj +Sub ChartPropMove() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartPropMove + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Sets the "move or size" setting for all charts + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + + For Each chtObj In Chart_GetObjectsFromObject(Selection) + chtObj.Placement = xlFreeFloating + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartTitleEqualsSeriesSelection -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Sets the chart title equal to the name of the first series -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub ChartTitleEqualsSeriesSelection() - - Dim myChartObject As ChartObject - - - For Each myChartObject In Selection - myChartObject.Chart.ChartTitle.Text = myChartObject.Chart.SeriesCollection(1).name - Next myChartObject - +Sub ChartTitleEqualsSeriesSelection() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartTitleEqualsSeriesSelection + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Sets the chart title equal to the name of the first series + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + + For Each chtObj In Selection + chtObj.Chart.ChartTitle.Text = chtObj.Chart.SeriesCollection(1).name + Next chtObj + End Sub diff --git a/src/code/Chart_Helpers.bas b/src/code/Chart_Helpers.bas index 54c00ae..e9e76df 100644 --- a/src/code/Chart_Helpers.bas +++ b/src/code/Chart_Helpers.bas @@ -1,22 +1,15 @@ Attribute VB_Name = "Chart_Helpers" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Chart_Helpers -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains code that helps other chart related features -'--------------------------------------------------------------------------------------- - -'--------------------------------------------------------------------------------------- -' Procedure : Chart_GetColor -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Returns a list of colors for styling chart series -'--------------------------------------------------------------------------------------- -' -Function Chart_GetColor(index As Variant) As Long +Public Function Chart_GetColor(index As Variant) As Long + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_GetColor + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Returns a list of colors for styling chart series + '--------------------------------------------------------------------------------------- + ' Dim colors(1 To 10) As Variant colors(6) = RGB(166, 206, 227) @@ -34,70 +27,84 @@ Function Chart_GetColor(index As Variant) As Long End Function -'--------------------------------------------------------------------------------------- -' Procedure : Chart_GetObjectsFromObject -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Helper function which finds a valid ChartObject based on what is actually selected -' Returns a Collection (possibly empty) and should be handled with a For Each -'--------------------------------------------------------------------------------------- -' -Function Chart_GetObjectsFromObject(incomingObject As Object) As Variant - Dim objectType As String - 'TODO: these should be upgrade to TypeOf instead of strings - objectType = TypeName(incomingObject) +Public Function Chart_GetObjectsFromObject(obj_in As Object) As Variant + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_GetObjectsFromObject + ' Author : @byronwall + ' Date : 2015 12 30 + ' Purpose : Helper function which finds a valid ChartObject based on what is actually selected + ' Returns a Collection (possibly empty) and should be handled with a For Each + '--------------------------------------------------------------------------------------- + ' + Dim chtObjCollection As New Collection - Dim newCollection As New Collection + 'NOTE that this function does not work well with Axis objects. Excel does not return the correct Parent for them. + + Dim obj As Variant - Dim newObject As Variant - If objectType = "DrawingObjects" Then + If TypeOf obj_in Is DrawingObjects Then 'this means that multiple charts are selected - For Each newObject In incomingObject - If TypeName(newObject) = "ChartObject" Then + + For Each obj In obj_in + If TypeName(obj) = "ChartObject" Then 'add it to the set - newCollection.Add newObject + chtObjCollection.Add obj End If - Next newObject - - ElseIf objectType = "Chart" Then - newCollection.Add incomingObject.Parent - - ElseIf objectType = "ChartArea" Or objectType = "PlotArea" Then + Next obj + + ElseIf TypeOf obj_in Is Worksheet Then + For Each obj In obj_in.ChartObjects + chtObjCollection.Add obj + Next obj + + ElseIf TypeOf obj_in Is Chart Then + chtObjCollection.Add obj_in.Parent + + ElseIf TypeOf obj_in Is ChartArea _ + Or TypeOf obj_in Is PlotArea _ + Or TypeOf obj_in Is Legend _ + Or TypeOf obj_in Is ChartTitle Then 'parent is the chart, parent of that is the chart obj - newCollection.Add incomingObject.Parent.Parent + chtObjCollection.Add obj_in.Parent.Parent - ElseIf objectType = "Series" Then + ElseIf TypeOf obj_in Is series Then 'need to go up three levels - newCollection.Add incomingObject.Parent.Parent.Parent + chtObjCollection.Add obj_in.Parent.Parent.Parent + + ElseIf TypeOf obj_in Is Axis _ + Or TypeOf obj_in Is Gridlines _ + Or TypeOf obj_in Is AxisTitle Then + 'these are the oddly unsupported objects + MsgBox "Axis/gridline selection not supported. This is an Excel bug. Select another element on the chart(s)." Else - MsgBox "Select an object that is supported." - End If + MsgBox "Select a part of the chart(s), except an axis." - Set Chart_GetObjectsFromObject = newCollection + End If + Set Chart_GetObjectsFromObject = chtObjCollection End Function -'--------------------------------------------------------------------------------------- -' Procedure : DeleteAllCharts -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Helper Sub to delete all charts on ActiveSheet -'--------------------------------------------------------------------------------------- -' -Sub DeleteAllCharts() +Public Sub DeleteAllCharts() + '--------------------------------------------------------------------------------------- + ' Procedure : DeleteAllCharts + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Helper Sub to delete all charts on ActiveSheet + '--------------------------------------------------------------------------------------- + ' If MsgBox("Delete all charts?", vbYesNo) = vbYes Then Application.ScreenUpdating = False - Dim iCounter As Long - For iCounter = ActiveSheet.ChartObjects.count To 1 Step -1 + Dim chtObjIndex As Long + For chtObjIndex = ActiveSheet.ChartObjects.count To 1 Step -1 - ActiveSheet.ChartObjects(iCounter).Delete + ActiveSheet.ChartObjects(chtObjIndex).Delete - Next iCounter + Next chtObjIndex Application.ScreenUpdating = True diff --git a/src/code/Chart_Processing.bas b/src/code/Chart_Processing.bas index f957eea..acf50cf 100644 --- a/src/code/Chart_Processing.bas +++ b/src/code/Chart_Processing.bas @@ -1,195 +1,192 @@ Attribute VB_Name = "Chart_Processing" -'--------------------------------------------------------------------------------------- -' Module : Chart_Processing -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains some of the heavy lifting processing code for charts -'--------------------------------------------------------------------------------------- - Option Explicit Public Sub Chart_CreateChartWithSeriesForEachColumn() -'will create a chart that includes a series with no x value for each column + 'will create a chart that includes a series with no x value for each column - Dim dataRange As Range - Set dataRange = GetInputOrSelection("Select chart data") + Dim rngData As Range + Set rngData = GetInputOrSelection("Select chart data") 'create a chart - Dim myChart As ChartObject - Set myChart = ActiveSheet.ChartObjects.Add(0, 0, 300, 300) + Dim chtObj As ChartObject + Set chtObj = ActiveSheet.ChartObjects.Add(0, 0, 300, 300) - myChart.Chart.ChartType = xlXYScatter + chtObj.Chart.ChartType = xlXYScatter - Dim rangeColumn As Range - For Each rangeColumn In dataRange.Columns + Dim rngColumn As Range + For Each rngColumn In rngData.Columns - Dim chartRange As Range - Set chartRange = RangeEnd(rangeColumn.Cells(1, 1), xlDown) + Dim rngChartData As Range + Set rngChartData = RangeEnd(rngColumn.Cells(1, 1), xlDown) - Dim ButlSeries As New bUTLChartSeries - Set ButlSeries.Values = chartRange + Dim butlSeries As New bUTLChartSeries + Set butlSeries.Values = rngChartData - ButlSeries.AddSeriesToChart myChart.Chart + butlSeries.AddSeriesToChart chtObj.Chart Next End Sub Public Sub Chart_CopyToSheet() - Dim myChart As ChartObject + Dim chtObj As ChartObject - Dim allObjects As Object - Set allObjects = Selection + Dim objSelection As Object + Set objSelection = Selection - Dim wantNewSheet As VbMsgBoxResult - wantNewSheet = MsgBox("New sheet?", vbYesNo, "New sheet?") + Dim newSheetResult As VbMsgBoxResult + newSheetResult = MsgBox("New sheet?", vbYesNo, "New sheet?") - Dim newSheet As Worksheet - If wantNewSheet = vbYes Then - Set newSheet = Worksheets.Add() + Dim shtOutput As Worksheet + If newSheetResult = vbYes Then + Set shtOutput = Worksheets.Add() Else - Set newSheet = Application.InputBox("Pick a cell on a sheet", "Pick sheet", Type:=8).Parent + Set shtOutput = Application.InputBox("Pick a cell on a sheet", "Pick sheet", Type:=8).Parent End If - For Each myChart In Chart_GetObjectsFromObject(allObjects) - myChart.Copy + For Each chtObj In Chart_GetObjectsFromObject(objSelection) + chtObj.Copy - newSheet.Paste + shtOutput.Paste Next - newSheet.Activate + shtOutput.Activate End Sub Sub Chart_SortSeriesByName() -'this will sort series by names - Dim myChart As ChartObject - For Each myChart In Chart_GetObjectsFromObject(Selection) + 'this will sort series by names + Dim chtObj As ChartObject + For Each chtObj In Chart_GetObjectsFromObject(Selection) 'uses a simple bubble sort but it works... shouldn't have 1000 series anyways - Dim firstChart As Long - Dim secondChart As Long - For firstChart = 1 To myChart.Chart.SeriesCollection.count - For secondChart = (firstChart + 1) To myChart.Chart.SeriesCollection.count + Dim chtIndex1 As Long + Dim chtIndex2 As Long + For chtIndex1 = 1 To chtObj.Chart.SeriesCollection.count + For chtIndex2 = (chtIndex1 + 1) To chtObj.Chart.SeriesCollection.count - Dim FirstButlSeries As New bUTLChartSeries - Dim SecondButlSeries As New bUTLChartSeries + Dim butlSeries1 As New bUTLChartSeries + Dim butlSeries2 As New bUTLChartSeries - FirstButlSeries.UpdateFromChartSeries myChart.Chart.SeriesCollection(firstChart) - SecondButlSeries.UpdateFromChartSeries myChart.Chart.SeriesCollection(secondChart) + butlSeries1.UpdateFromChartSeries chtObj.Chart.SeriesCollection(chtIndex1) + butlSeries2.UpdateFromChartSeries chtObj.Chart.SeriesCollection(chtIndex2) - If FirstButlSeries.name.Value > SecondButlSeries.name.Value Then - Dim numberSeries As Long - numberSeries = SecondButlSeries.SeriesNumber - SecondButlSeries.SeriesNumber = FirstButlSeries.SeriesNumber - FirstButlSeries.SeriesNumber = numberSeries + If butlSeries1.name.Value > butlSeries2.name.Value Then + Dim indexSeriesSwap As Long + indexSeriesSwap = butlSeries2.SeriesNumber + butlSeries2.SeriesNumber = butlSeries1.SeriesNumber + butlSeries1.SeriesNumber = indexSeriesSwap - SecondButlSeries.UpdateSeriesWithNewValues - FirstButlSeries.UpdateSeriesWithNewValues + butlSeries2.UpdateSeriesWithNewValues + butlSeries1.UpdateSeriesWithNewValues End If Next Next Next End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_TimeSeries -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Helper Sub to create a set of charts with the same x axis and varying y -'--------------------------------------------------------------------------------------- -' -Sub Chart_TimeSeries(dateRange As Range, dataRange As Range, titles As Range) - Dim counter As Long - counter = 1 +Sub Chart_TimeSeries(rngDates As Range, rngData As Range, rngTitles As Range) + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_TimeSeries + ' Author : @byronwall + ' Date : 2015 12 30 + ' Purpose : Helper Sub to create a set of charts with the same x axis and varying y + '--------------------------------------------------------------------------------------- + ' + Application.ScreenUpdating = False + + Dim chartIndex As Long + chartIndex = 1 + + Dim rngTitle As Range + Dim rngColumn As Range - Dim title As Range - Dim rangeColumn As Range + For Each rngTitle In rngTitles - For Each title In titles + Dim chtObj As ChartObject + Set chtObj = ActiveSheet.ChartObjects.Add(chartIndex * 300, 0, 300, 300) - Dim myChartObject As ChartObject - Set myChartObject = ActiveSheet.ChartObjects.Add(counter * 300, 0, 300, 300) + Dim cht As Chart + Set cht = chtObj.Chart + cht.ChartType = xlXYScatterLines + cht.HasTitle = True + cht.Legend.Delete - Dim myChart As Chart - Set myChart = myChartObject.Chart - myChart.ChartType = xlXYScatterLines - myChart.HasTitle = True - myChart.Legend.Delete + Dim chtAxis As Axis + Set chtAxis = cht.Axes(xlValue) + chtAxis.MajorGridlines.Border.Color = RGB(200, 200, 200) - Dim myAxis As Axis - Set myAxis = myChart.Axes(xlValue) - myAxis.MajorGridlines.Border.Color = RGB(200, 200, 200) + Dim chtSeries As series + Dim butlSeries As New bUTLChartSeries - Dim mySeries As series - Dim ButlSeries As New bUTLChartSeries + Set butlSeries.XValues = rngDates + Set butlSeries.Values = rngData.Columns(chartIndex) + Set butlSeries.name = rngTitle - Set ButlSeries.XValues = dateRange - Set ButlSeries.Values = dataRange.Columns(counter) - Set ButlSeries.name = title + Set chtSeries = butlSeries.AddSeriesToChart(cht) - Set mySeries = ButlSeries.AddSeriesToChart(myChart) + chtSeries.MarkerSize = 3 + chtSeries.MarkerStyle = xlMarkerStyleCircle - mySeries.MarkerSize = 3 - mySeries.MarkerStyle = xlMarkerStyleCircle + chartIndex = chartIndex + 1 - counter = counter + 1 + Next rngTitle - Next title + Application.ScreenUpdating = True End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_TimeSeries_FastCreation -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : this will create a fast set of charts from a block of data -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub Chart_TimeSeries_FastCreation() - Dim dateRange As Range - Dim dataRange As Range - Dim titles As Range +Sub Chart_TimeSeries_FastCreation() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_TimeSeries_FastCreation + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : this will create a fast set of charts from a block of data + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + Dim rngDates As Range + Dim rngData As Range + Dim rngTitles As Range 'dates are in B4 and down - Set dateRange = RangeEnd_Boundary(Range("B4"), xlDown) + Set rngDates = RangeEnd_Boundary(Range("B4"), xlDown) 'data starts in C4, down and over - Set dataRange = RangeEnd_Boundary(Range("C4"), xlDown, xlToRight) + Set rngData = RangeEnd_Boundary(Range("C4"), xlDown, xlToRight) 'titels are C2 and over - Set titles = RangeEnd_Boundary(Range("C2"), xlToRight) + Set rngTitles = RangeEnd_Boundary(Range("C2"), xlToRight) - Chart_TimeSeries dateRange, dataRange, titles + Chart_TimeSeries rngDates, rngData, rngTitles ChartDefaultFormat Chart_GridOfCharts End Sub -'--------------------------------------------------------------------------------------- -' Procedure : CreateMultipleTimeSeries -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Entry point from Ribbon to create a set of time series charts -'--------------------------------------------------------------------------------------- -' -Sub CreateMultipleTimeSeries() - Dim dateRange As Range - Dim dataRange As Range - Dim titles As Range +Sub CreateMultipleTimeSeries() + '--------------------------------------------------------------------------------------- + ' Procedure : CreateMultipleTimeSeries + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Entry point from Ribbon to create a set of time series charts + '--------------------------------------------------------------------------------------- + ' + Dim rngDates As Range + Dim rngData As Range + Dim rngTitles As Range On Error GoTo CreateMultipleTimeSeries_Error DeleteAllCharts - Set dateRange = Application.InputBox("Select date range", Type:=8) - Set dataRange = Application.InputBox("Select data", Type:=8) - Set titles = Application.InputBox("Select titles", Type:=8) + Set rngDates = Application.InputBox("Select date range", Type:=8) + Set rngData = Application.InputBox("Select data", Type:=8) + Set rngTitles = Application.InputBox("Select titles", Type:=8) - Chart_TimeSeries dateRange, dataRange, titles + Chart_TimeSeries rngDates, rngData, rngTitles On Error GoTo 0 Exit Sub @@ -200,40 +197,40 @@ CreateMultipleTimeSeries_Error: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : RemoveZeroValueDataLabel -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Code deletes data labels that have 0 value -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub RemoveZeroValueDataLabel() - -'uses the ActiveChart, be sure a chart is selected - Dim myChart As Chart - Set myChart = ActiveChart - Dim mySeries As series - For Each mySeries In myChart.SeriesCollection - - Dim myValues As Variant - myValues = mySeries.Values +Sub RemoveZeroValueDataLabel() + '--------------------------------------------------------------------------------------- + ' Procedure : RemoveZeroValueDataLabel + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Code deletes data labels that have 0 value + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + 'uses the ActiveChart, be sure a chart is selected + Dim cht As Chart + Set cht = ActiveChart + + Dim chtSeries As series + For Each chtSeries In cht.SeriesCollection + + Dim chtValues As Variant + chtValues = chtSeries.Values 'include this line if you want to reestablish labels before deleting - mySeries.ApplyDataLabels xlDataLabelsShowLabel, , , , True, False, False, False, False + chtSeries.ApplyDataLabels xlDataLabelsShowLabel, , , , True, False, False, False, False 'loop through values and delete 0-value labels - Dim i As Long - For i = LBound(myValues) To UBound(myValues) - If myValues(i) = 0 Then - With mySeries.Points(i) + Dim pointIndex As Long + For pointIndex = LBound(chtValues) To UBound(chtValues) + If chtValues(pointIndex) = 0 Then + With chtSeries.Points(pointIndex) If .HasDataLabel Then .DataLabel.Delete End If End With End If - Next i - Next mySeries + Next pointIndex + Next chtSeries End Sub diff --git a/src/code/Chart_Series.bas b/src/code/Chart_Series.bas index ca4de85..e32241e 100644 --- a/src/code/Chart_Series.bas +++ b/src/code/Chart_Series.bas @@ -1,208 +1,192 @@ Attribute VB_Name = "Chart_Series" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Chart_Series -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains charting code related to managing series -'--------------------------------------------------------------------------------------- - - -'--------------------------------------------------------------------------------------- -' Procedure : Chart_AddTrendlineToSeriesAndColor -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Adds a trendline to each series in all charts -'--------------------------------------------------------------------------------------- -' Sub Chart_AddTrendlineToSeriesAndColor() - - Dim myChartObject As ChartObject - - For Each myChartObject In Chart_GetObjectsFromObject(Selection) - - Dim mySeries As series - - Dim i As Long - i = 1 - - For Each mySeries In myChartObject.Chart.SeriesCollection - - Dim ButlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_AddTrendlineToSeriesAndColor + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Adds a trendline to each series in all charts + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + + For Each chtObj In Chart_GetObjectsFromObject(Selection) + Dim chartIndex As Long + chartIndex = 1 + + Dim chtSeries As series + For Each chtSeries In chtObj.Chart.SeriesCollection + + Dim butlSeries As New bUTLChartSeries + butlSeries.UpdateFromChartSeries chtSeries 'clear out old ones Dim j As Long - For j = 1 To mySeries.Trendlines.count - mySeries.Trendlines(j).Delete + For j = 1 To chtSeries.Trendlines.count + chtSeries.Trendlines(j).Delete Next j - mySeries.MarkerBackgroundColor = Chart_GetColor(i) + chtSeries.MarkerBackgroundColor = Chart_GetColor(chartIndex) Dim trend As Trendline - Set trend = mySeries.Trendlines.Add() + Set trend = chtSeries.Trendlines.Add() trend.Type = xlLinear - trend.Border.Color = mySeries.MarkerBackgroundColor + trend.Border.Color = chtSeries.MarkerBackgroundColor '2015 11 06 test to avoid error without name - If Not ButlSeries.name Is Nothing Then - trend.name = ButlSeries.name + '2015 12 07 dealing with multi-cell Names + 'TODO: handle if the name is not a range also + If Not butlSeries.name Is Nothing Then + trend.name = butlSeries.name.Cells(1, 1).Value End If trend.DisplayEquation = True trend.DisplayRSquared = True - trend.DataLabel.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Chart_GetColor(i) + trend.DataLabel.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Chart_GetColor(chartIndex) - i = i + 1 - Next mySeries + chartIndex = chartIndex + 1 + Next chtSeries - Next myChartObject + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_ExtendSeriesToRanges -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Extends the underlying data for a series to go to the end of its current Range -'--------------------------------------------------------------------------------------- -' -Sub Chart_ExtendSeriesToRanges() - Dim myChartObject As ChartObject +Sub Chart_ExtendSeriesToRanges() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_ExtendSeriesToRanges + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Extends the underlying data for a series to go to the end of its current Range + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) + For Each chtObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series + Dim chtSeries As series 'get each series - For Each mySeries In myChartObject.Chart.SeriesCollection + For Each chtSeries In chtObj.Chart.SeriesCollection 'create the bUTL obj and manipulate series ranges - Dim ButlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries + Dim butlSeries As New bUTLChartSeries + butlSeries.UpdateFromChartSeries chtSeries - If Not ButlSeries.XValues Is Nothing Then - mySeries.XValues = RangeEnd(ButlSeries.XValues.Cells(1), xlDown) + If Not butlSeries.XValues Is Nothing Then + chtSeries.XValues = RangeEnd(butlSeries.XValues.Cells(1), xlDown) End If - mySeries.Values = RangeEnd(ButlSeries.Values.Cells(1), xlDown) - - Next mySeries - - Next myChartObject - + chtSeries.Values = RangeEnd(butlSeries.Values.Cells(1), xlDown) + Next chtSeries + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_GoToXRange -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Selects the x value range that is used for the series -'--------------------------------------------------------------------------------------- -' -Sub Chart_GoToXRange() - +Sub Chart_GoToXRange() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_GoToXRange + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Selects the x value range that is used for the series + '--------------------------------------------------------------------------------------- + ' If TypeName(Selection) = "Series" Then - Dim ButlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries Selection + Dim b As New bUTLChartSeries + b.UpdateFromChartSeries Selection - ButlSeries.XValues.Parent.Activate - ButlSeries.XValues.Activate + b.XValues.Parent.Activate + b.XValues.Activate Else MsgBox "Select a series in order to use this." End If End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_GoToYRange -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Selects the y values used for the series -'--------------------------------------------------------------------------------------- -' -Sub Chart_GoToYRange() - +Sub Chart_GoToYRange() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_GoToYRange + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Selects the y values used for the series + '--------------------------------------------------------------------------------------- + ' If TypeName(Selection) = "Series" Then - Dim ButlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries Selection + Dim b As New bUTLChartSeries + b.UpdateFromChartSeries Selection - ButlSeries.Values.Parent.Activate - ButlSeries.Values.Activate + b.Values.Parent.Activate + b.Values.Activate Else MsgBox "Select a series in order to use this." End If End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_RemoveTrendlines -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Remove all trendlines from a chart -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub Chart_RemoveTrendlines() - Dim myChartObject As ChartObject +Sub Chart_RemoveTrendlines() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_RemoveTrendlines + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Remove all trendlines from a chart + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) + For Each chtObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series - For Each mySeries In myChartObject.Chart.SeriesCollection + Dim chtSeries As series + For Each chtSeries In chtObj.Chart.SeriesCollection Dim trend As Trendline - - For Each trend In mySeries.Trendlines + For Each trend In chtSeries.Trendlines trend.Delete Next trend - - Next mySeries - - Next myChartObject + Next chtSeries + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_RerangeSeries -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Entry point for an interface to help rerange series -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub Chart_RerangeSeries() +Sub Chart_RerangeSeries() + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_RerangeSeries + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Entry point for an interface to help rerange series + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' Dim frm As New form_chtSeries frm.Show End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Chart_TrendlinesToAverage -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Creates a trendline using a moving average instead of linear -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' + Sub Chart_TrendlinesToAverage() - Dim myChartObject As ChartObject + '--------------------------------------------------------------------------------------- + ' Procedure : Chart_TrendlinesToAverage + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Creates a trendline using a moving average instead of linear + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) + For Each chtObj In Chart_GetObjectsFromObject(Selection) - Dim mySeries As series + Dim chtSeries As series - For Each mySeries In myChartObject.Chart.SeriesCollection + For Each chtSeries In chtObj.Chart.SeriesCollection Dim trend As Trendline - For Each trend In mySeries.Trendlines + For Each trend In chtSeries.Trendlines trend.Type = xlMovingAvg trend.Period = 15 trend.Format.Line.Weight = 2 @@ -212,165 +196,166 @@ Sub Chart_TrendlinesToAverage() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartFlipXYValues -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Flips the x/y ranges for each series -'--------------------------------------------------------------------------------------- -' -Sub ChartFlipXYValues() - - Dim myChartObject As ChartObject - Dim myChart As Chart - For Each myChartObject In Chart_GetObjectsFromObject(Selection) - Set myChart = myChartObject.Chart - Dim mySeries As series - - Dim ButlSeriesies As New Collection - Dim ButlSeries As bUTLChartSeries - - For Each mySeries In myChart.SeriesCollection - Set ButlSeries = New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries - - Dim rng_dummy As Range - - Set rng_dummy = ButlSeries.Values - Set ButlSeries.Values = ButlSeries.XValues - Set ButlSeries.XValues = rng_dummy +Sub ChartFlipXYValues() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartFlipXYValues + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Flips the x/y ranges for each series + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + Dim cht As Chart + For Each chtObj In Chart_GetObjectsFromObject(Selection) + Set cht = chtObj.Chart + + Dim butlSeriesies As New Collection + Dim butlSeries As bUTLChartSeries + + Dim chtSeries As series + For Each chtSeries In cht.SeriesCollection + Set butlSeries = New bUTLChartSeries + butlSeries.UpdateFromChartSeries chtSeries + + Dim rngDummy As Range + + Set rngDummy = butlSeries.Values + Set butlSeries.Values = butlSeries.XValues + Set butlSeries.XValues = rngDummy 'need to change the series name also 'assume that title is same offset 'code blocked for now - If False And Not ButlSeries.name Is Nothing Then + If False And Not butlSeries.name Is Nothing Then Dim int_offset_rows As Long, int_offset_cols As Long - int_offset_rows = ButlSeries.name.row - ButlSeries.XValues.Cells(1, 1).row - int_offset_cols = ButlSeries.name.Column - ButlSeries.XValues.Cells(1, 1).Column + int_offset_rows = butlSeries.name.Row - butlSeries.XValues.Cells(1, 1).Row + int_offset_cols = butlSeries.name.Column - butlSeries.XValues.Cells(1, 1).Column - Set ButlSeries.name = ButlSeries.Values.Cells(1, 1).Offset(int_offset_rows, int_offset_cols) + Set butlSeries.name = butlSeries.Values.Cells(1, 1).Offset(int_offset_rows, int_offset_cols) End If - ButlSeries.UpdateSeriesWithNewValues + butlSeries.UpdateSeriesWithNewValues - Next mySeries + Next chtSeries ''need to flip axis labels if they exist - - ''three cases: X only, Y only, X and Y - If myChart.Axes(xlCategory).HasTitle And Not myChart.Axes(xlValue).HasTitle Then + If cht.Axes(xlCategory).HasTitle And Not cht.Axes(xlValue).HasTitle Then - myChart.Axes(xlValue).HasTitle = True - myChart.Axes(xlValue).AxisTitle.Text = myChart.Axes(xlCategory).AxisTitle.Text - myChart.Axes(xlCategory).HasTitle = False + cht.Axes(xlValue).HasTitle = True + cht.Axes(xlValue).AxisTitle.Text = cht.Axes(xlCategory).AxisTitle.Text + cht.Axes(xlCategory).HasTitle = False - ElseIf Not myChart.Axes(xlCategory).HasTitle And myChart.Axes(xlValue).HasTitle Then - myChart.Axes(xlCategory).HasTitle = True - myChart.Axes(xlCategory).AxisTitle.Text = myChart.Axes(xlValue).AxisTitle.Text - myChart.Axes(xlValue).HasTitle = False - ElseIf myChart.Axes(xlCategory).HasTitle And myChart.Axes(xlValue).HasTitle Then - Dim tempString As String + ElseIf Not cht.Axes(xlCategory).HasTitle And cht.Axes(xlValue).HasTitle Then + cht.Axes(xlCategory).HasTitle = True + cht.Axes(xlCategory).AxisTitle.Text = cht.Axes(xlValue).AxisTitle.Text + cht.Axes(xlValue).HasTitle = False + + ElseIf cht.Axes(xlCategory).HasTitle And cht.Axes(xlValue).HasTitle Then + Dim swapText As String - tempString = myChart.Axes(xlCategory).AxisTitle.Text + swapText = cht.Axes(xlCategory).AxisTitle.Text - myChart.Axes(xlCategory).AxisTitle.Text = myChart.Axes(xlValue).AxisTitle.Text - myChart.Axes(xlValue).AxisTitle.Text = tempString + cht.Axes(xlCategory).AxisTitle.Text = cht.Axes(xlValue).AxisTitle.Text + cht.Axes(xlValue).AxisTitle.Text = swapText End If - Set ButlSeriesies = Nothing + Set butlSeriesies = Nothing - Next myChartObject + Next chtObj End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartMergeSeries -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Merges all selected charts into a single chart -'--------------------------------------------------------------------------------------- -' -Sub ChartMergeSeries() - Dim myChartObject As ChartObject - Dim myChart As Chart - +Sub ChartMergeSeries() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartMergeSeries + ' Author : @byronwall + ' Date : 2015 12 30 + ' Purpose : Merges all selected charts into a single chart + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + Dim cht As Chart + Dim sel As Variant Dim firstChart As Chart - Dim first As Boolean - first = True + Dim isFirstChart As Boolean + isFirstChart = True - For Each myChartObject In Chart_GetObjectsFromObject(Selection) + Application.ScreenUpdating = False - Set myChart = myChartObject.Chart - If first Then - Set firstChart = myChart - first = False + For Each chtObj In Chart_GetObjectsFromObject(Selection) + + Set cht = chtObj.Chart + If isFirstChart Then + Set firstChart = cht + isFirstChart = False Else - Dim mySeries As series - For Each mySeries In myChart.SeriesCollection + Dim chtSeries As series + For Each chtSeries In cht.SeriesCollection - Dim newSeries As series - Dim ButlSeries As New bUTLChartSeries + Dim chtNewSeries As series + Dim butlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries - Set newSeries = ButlSeries.AddSeriesToChart(firstChart) + butlSeries.UpdateFromChartSeries chtSeries + Set chtNewSeries = butlSeries.AddSeriesToChart(firstChart) - newSeries.MarkerSize = mySeries.MarkerSize - newSeries.MarkerStyle = mySeries.MarkerStyle + chtNewSeries.MarkerSize = chtSeries.MarkerSize + chtNewSeries.MarkerStyle = chtSeries.MarkerStyle - mySeries.Delete + chtSeries.Delete - Next mySeries + Next chtSeries - myChartObject.Delete + chtObj.Delete End If - Next myChartObject + Next chtObj + + Application.ScreenUpdating = True End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ChartSplitSeries -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Take all series from selected charts and puts them in their own charts -'--------------------------------------------------------------------------------------- -' -Sub ChartSplitSeries() - Dim myChartObject As ChartObject - - +Sub ChartSplitSeries() + '--------------------------------------------------------------------------------------- + ' Procedure : ChartSplitSeries + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Take all series from selected charts and puts them in their own charts + '--------------------------------------------------------------------------------------- + ' + Dim chtObj As ChartObject + Dim cht As Chart - Dim mySeries As series - For Each myChartObject In Chart_GetObjectsFromObject(Selection) + Dim chtSeries As series + For Each chtObj In Chart_GetObjectsFromObject(Selection) - For Each mySeries In myChartObject.Chart.SeriesCollection + For Each chtSeries In chtObj.Chart.SeriesCollection - Dim newChartObject As ChartObject - Set newChartObject = ActiveSheet.ChartObjects.Add(0, 0, 300, 300) + Dim chtObjNew As ChartObject + Set chtObjNew = ActiveSheet.ChartObjects.Add(0, 0, 300, 300) - Dim newSeries As series - Dim ButlSeries As New bUTLChartSeries + Dim chtSeriesNew As series + Dim butlSeries As New bUTLChartSeries - ButlSeries.UpdateFromChartSeries mySeries - Set newSeries = ButlSeries.AddSeriesToChart(newChartObject.Chart) + butlSeries.UpdateFromChartSeries chtSeries + Set chtSeriesNew = butlSeries.AddSeriesToChart(chtObjNew.Chart) - newSeries.MarkerSize = mySeries.MarkerSize - newSeries.MarkerStyle = mySeries.MarkerStyle + chtSeriesNew.MarkerSize = chtSeries.MarkerSize + chtSeriesNew.MarkerStyle = chtSeries.MarkerStyle - mySeries.Delete + chtSeries.Delete - Next mySeries + Next chtSeries - myChartObject.Delete + chtObj.Delete - Next myChartObject + Next chtObj End Sub diff --git a/src/code/Formatting_Helpers.bas b/src/code/Formatting_Helpers.bas index 6505f04..76fad12 100644 --- a/src/code/Formatting_Helpers.bas +++ b/src/code/Formatting_Helpers.bas @@ -1,48 +1,43 @@ Attribute VB_Name = "Formatting_Helpers" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Formatting_Helpers -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : contains code related to formatting and other cell value stuff -'--------------------------------------------------------------------------------------- - -'--------------------------------------------------------------------------------------- -' Procedure : CategoricalColoring -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Applies the formatting from one range to another if cell value's match -'--------------------------------------------------------------------------------------- -' + Public Sub CategoricalColoring() -'+Get User Input - Dim rangeToColor As Range + '--------------------------------------------------------------------------------------- + ' Procedure : CategoricalColoring + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Applies the formatting from one range to another if cell value's match + '--------------------------------------------------------------------------------------- + ' + + '+Get User Input + Dim rngToColor As Range On Error GoTo errHandler - Set rangeToColor = GetInputOrSelection("Select Range to Color") + Set rngToColor = GetInputOrSelection("Select Range to Color") - Dim rangeWithColors As Range - Set rangeWithColors = GetInputOrSelection("Select Range with Colors") + Dim rngColors As Range + Set rngColors = GetInputOrSelection("Select Range with Colors") '+Do Magic Application.ScreenUpdating = False - Dim myRange As Range - Dim variableRow As Variant + Dim c As Range + Dim varRow As Variant - For Each myRange In rangeToColor - variableRow = Application.Match(myRange, rangeWithColors, 0) + For Each c In rngToColor + varRow = Application.Match(c, rngColors, 0) '+ Matches font style as well as interior color - If IsNumeric(variableRow) Then - myRange.Font.FontStyle = rangeWithColors.Cells(variableRow).Font.FontStyle - myRange.Font.Color = rangeWithColors.Cells(variableRow).Font.Color + If IsNumeric(varRow) Then + c.Font.FontStyle = rngColors.Cells(varRow).Font.FontStyle + c.Font.Color = rngColors.Cells(varRow).Font.Color '+Skip interior color if there is none - If Not rangeWithColors.Cells(variableRow).Interior.ColorIndex = xlNone Then - myRange.Interior.Color = rangeWithColors.Cells(variableRow).Interior.Color + If Not rngColors.Cells(varRow).Interior.ColorIndex = xlNone Then + c.Interior.Color = rngColors.Cells(varRow).Interior.Color End If End If - Next myRange + Next c '+ If no fill, restore gridlines - rangeToColor.Borders.LineStyle = xlNone + rngToColor.Borders.LineStyle = xlNone Application.ScreenUpdating = True Exit Sub errHandler: @@ -50,62 +45,62 @@ errHandler: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ColorForUnique -' Author : @byronwall, @RaymondWise -' Date : 2015 07 29 -' Purpose : Adds the same unique color to each unique value in a range -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub ColorForUnique() +Sub ColorForUnique() + '--------------------------------------------------------------------------------------- + ' Procedure : ColorForUnique + ' Author : @byronwall, @RaymondWise + ' Date : 2015 07 29 + ' Purpose : Adds the same unique color to each unique value in a range + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' Dim dictKeysAndColors As New Scripting.Dictionary Dim dictColorsOnly As New Scripting.Dictionary - Dim rangeToColor As Range + Dim rngToColor As Range On Error GoTo ColorForUnique_Error - Set rangeToColor = GetInputOrSelection("Select column to color") - Set rangeToColor = Intersect(rangeToColor, rangeToColor.Parent.UsedRange) + Set rngToColor = GetInputOrSelection("Select column to color") + Set rngToColor = Intersect(rngToColor, rngToColor.Parent.UsedRange) 'We can colorize the sorting column, or the entire row - Dim colorEntireRow As VbMsgBoxResult - colorEntireRow = MsgBox("Do you want to color the entire row?", vbYesNo) + Dim vShouldColorEntireRow As VbMsgBoxResult + vShouldColorEntireRow = MsgBox("Do you want to color the entire row?", vbYesNo) Application.ScreenUpdating = False Dim rngRowToColor As Range - For Each rngRowToColor In rangeToColor.Rows + For Each rngRowToColor In rngToColor.Rows 'allow for a multi column key if intial range is multi-column 'TODO: consider making this another prompt... might (?) want to color multi range based on single column key - Dim identification As String + Dim id As String If rngRowToColor.Columns.count > 1 Then - identification = Join(Application.Transpose(Application.Transpose(rngRowToColor.Value)), "||") + id = Join(Application.Transpose(Application.Transpose(rngRowToColor.Value)), "||") Else - identification = rngRowToColor.Value + id = rngRowToColor.Value End If 'new value, need a color - If Not dictKeysAndColors.Exists(identification) Then - Dim newRGB As Long + If Not dictKeysAndColors.Exists(id) Then + Dim lRgbColor As Long createNewColor: - newRGB = RGB(Application.RandBetween(50, 255), _ - Application.RandBetween(50, 255), Application.RandBetween(50, 255)) - If dictColorsOnly.Exists(newRGB) Then + lRgbColor = RGB(Application.RandBetween(50, 255), _ + Application.RandBetween(50, 255), Application.RandBetween(50, 255)) + If dictColorsOnly.Exists(lRgbColor) Then 'ensure unique colors only GoTo createNewColor End If - dictKeysAndColors.Add identification, newRGB + dictKeysAndColors.Add id, lRgbColor End If - If colorEntireRow = vbYes Then - rngRowToColor.EntireRow.Interior.Color = dictKeysAndColors(identification) + If vShouldColorEntireRow = vbYes Then + rngRowToColor.EntireRow.Interior.Color = dictKeysAndColors(id) Else - rngRowToColor.Interior.Color = dictKeysAndColors(identification) + rngRowToColor.Interior.Color = dictKeysAndColors(id) End If Next rngRowToColor @@ -119,46 +114,46 @@ ColorForUnique_Error: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Colorize -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Creates an alternating color band based on cell values -'--------------------------------------------------------------------------------------- -' -Public Sub Colorize() - Dim rangeToColor As Range +Public Sub Colorize() + '--------------------------------------------------------------------------------------- + ' Procedure : Colorize + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Creates an alternating color band based on cell values + '--------------------------------------------------------------------------------------- + ' + Dim rngToColor As Range On Error GoTo errHandler - Set rangeToColor = GetInputOrSelection("Select range to color") - Dim lastRow As Long - lastRow = rangeToColor.Rows.count + Set rngToColor = GetInputOrSelection("Select range to color") + Dim lastrow As Long + lastrow = rngToColor.Rows.count - Dim likeValues As VbMsgBoxResult - likeValues = MsgBox("Do you want to keep duplicate values the same color?", vbYesNo) + Dim likevalues As VbMsgBoxResult + likevalues = MsgBox("Do you want to keep duplicate values the same color?", vbYesNo) - If likeValues = vbNo Then + If likevalues = vbNo Then Dim i As Long - For i = 1 To lastRow + For i = 1 To lastrow If i Mod 2 = 0 Then - rangeToColor.Rows(i).Interior.Color = RGB(200, 200, 200) - Else: rangeToColor.Rows(i).Interior.ColorIndex = xlNone + rngToColor.Rows(i).Interior.Color = RGB(200, 200, 200) + Else: rngToColor.Rows(i).Interior.ColorIndex = xlNone End If Next End If - If likeValues = vbYes Then - Dim flipColors As Boolean - For i = 2 To lastRow - If rangeToColor.Cells(i, 1) <> rangeToColor.Cells(i - 1, 1) Then - flipColors = Not flipColors + If likevalues = vbYes Then + Dim flip As Boolean + For i = 2 To lastrow + If rngToColor.Cells(i, 1) <> rngToColor.Cells(i - 1, 1) Then + flip = Not flip End If - If flipColors Then - rangeToColor.Rows(i).Interior.Color = RGB(200, 200, 200) - Else: rangeToColor.Rows(i).Interior.ColorIndex = xlNone + If flip Then + rngToColor.Rows(i).Interior.Color = RGB(200, 200, 200) + Else: rngToColor.Rows(i).Interior.ColorIndex = xlNone End If Next End If @@ -167,14 +162,15 @@ errHandler: MsgBox ("No Range Selected!") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : CombineCells -' Author : @byronwall, @RaymondWise -' Date : 2015 07 24 -' Purpose : Takes a row of values and converts them to a single column -'--------------------------------------------------------------------------------------- -' + Sub CombineCells() + '--------------------------------------------------------------------------------------- + ' Procedure : CombineCells + ' Author : @byronwall, @RaymondWise + ' Date : 2015 07 24 + ' Purpose : Takes a row of values and converts them to a single column + '--------------------------------------------------------------------------------------- + ' 'collect all user data up front Dim rngInput As Range On Error GoTo errHandler @@ -216,15 +212,15 @@ errHandler: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ConvertToNumber -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Forces all numbers stored as text to be converted to actual numbers -'--------------------------------------------------------------------------------------- -' -Sub ConvertToNumber() +Sub ConvertToNumber() + '--------------------------------------------------------------------------------------- + ' Procedure : ConvertToNumber + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Forces all numbers stored as text to be converted to actual numbers + '--------------------------------------------------------------------------------------- + ' Dim cell As Range Dim sel As Range @@ -244,16 +240,16 @@ Sub ConvertToNumber() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : CopyTranspose -' Author : @byronwall, @RaymondWise -' Date : 2015 07 31 -' Purpose : Takes a range of cells and does a copy/tranpose -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub CopyTranspose() +Sub CopyTranspose() + '--------------------------------------------------------------------------------------- + ' Procedure : CopyTranspose + ' Author : @byronwall, @RaymondWise + ' Date : 2015 07 31 + ' Purpose : Takes a range of cells and does a copy/tranpose + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' 'If user cancels a range input, we need to handle it when it occurs On Error GoTo errCancel Dim rngSelect As Range @@ -271,27 +267,27 @@ Sub CopyTranspose() Set rCorner = rngSelect.Cells(1, 1) Dim iCRow As Long - iCRow = rCorner.row + iCRow = rCorner.Row Dim iCCol As Long iCCol = rCorner.Column Dim iORow As Long Dim iOCol As Long - iORow = rngOut.row + iORow = rngOut.Row iOCol = rngOut.Column Dim c As Range 'We check for the intersection to ensure we don't overwrite any of the original data For Each c In rngSelect - If Not Intersect(rngSelect, Cells(iORow + c.Column - iCCol, iOCol + c.row - iCRow)) Is Nothing Then + If Not Intersect(rngSelect, Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow)) Is Nothing Then MsgBox ("Your destination intersects with your data") Exit Sub End If Next c For Each c In rngSelect - ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.row - iCRow).Formula = c.Formula + ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).Formula = c.Formula Next c Application.ScreenUpdating = True @@ -304,26 +300,27 @@ End Sub -'--------------------------------------------------------------------------------------- -' Procedure : CreateConditionalsForFormatting -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Creates a set of conditional formats for order of magnitude numbers -'--------------------------------------------------------------------------------------- -' + Sub CreateConditionalsForFormatting() + '--------------------------------------------------------------------------------------- + ' Procedure : CreateConditionalsForFormatting + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Creates a set of conditional formats for order of magnitude numbers + '--------------------------------------------------------------------------------------- + ' On Error GoTo errHandler Dim rngInput As Range Set rngInput = GetInputOrSelection("Select the range of cells to convert") 'add these in as powers of 3, starting at 1 = 10^0 Dim arrMarkers As Variant - arrMarkers = Array("", "k", "M", "B") + arrMarkers = Array(" ", "k", "M", "B", "T", "Q") Dim i As Long For i = UBound(arrMarkers) To 0 Step -1 With rngInput.FormatConditions.Add(xlCellValue, xlGreaterEqual, 10 ^ (3 * i)) - .NumberFormat = "0" & Application.WorksheetFunction.Rept(",", i) & " "" " & arrMarkers(i) & """" + .NumberFormat = "0.0" & Application.WorksheetFunction.Rept(",", i) & " "" " & arrMarkers(i) & """" End With Next @@ -332,15 +329,15 @@ errHandler: MsgBox ("No Range Selected!") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ExtendArrayFormulaDown -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Takes an array formula and extends it down as far as the range on its right goes -'--------------------------------------------------------------------------------------- -' -Sub ExtendArrayFormulaDown() +Sub ExtendArrayFormulaDown() + '--------------------------------------------------------------------------------------- + ' Procedure : ExtendArrayFormulaDown + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Takes an array formula and extends it down as far as the range on its right goes + '--------------------------------------------------------------------------------------- + ' Dim rngArrForm As Range Dim RngArea As Range @@ -381,15 +378,16 @@ Sub ExtendArrayFormulaDown() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : MakeHyperlinks -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Converts a set of cells to hyperlink to their cell value -'--------------------------------------------------------------------------------------- -' + Sub MakeHyperlinks() -'+Changed to inputbox + '--------------------------------------------------------------------------------------- + ' Procedure : MakeHyperlinks + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Converts a set of cells to hyperlink to their cell value + '--------------------------------------------------------------------------------------- + ' + '+Changed to inputbox On Error GoTo errHandler Dim rngEval As Range Set rngEval = GetInputOrSelection("Select the range of cells to convert to hyperlink") @@ -404,16 +402,16 @@ errHandler: MsgBox ("No Range Selected!") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : OutputColors -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Outputs the list of chart colors available -' Flag : not-used -'--------------------------------------------------------------------------------------- -' + Sub OutputColors() - + '--------------------------------------------------------------------------------------- + ' Procedure : OutputColors + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Outputs the list of chart colors available + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' Dim i As Long For i = 1 To 10 ActiveCell.Offset(i).Interior.Color = Chart_GetColor(i) @@ -421,15 +419,15 @@ Sub OutputColors() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SelectedToValue -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Forces a cell to take on its value. Removes formulas. -'--------------------------------------------------------------------------------------- -' -Sub SelectedToValue() +Sub SelectedToValue() + '--------------------------------------------------------------------------------------- + ' Procedure : SelectedToValue + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Forces a cell to take on its value. Removes formulas. + '--------------------------------------------------------------------------------------- + ' Dim rng As Range On Error GoTo errHandler Set rng = GetInputOrSelection("Select the formulas you'd like to convert to static values") @@ -443,26 +441,26 @@ errHandler: MsgBox ("No selection made!") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : Selection_ColorWithHex -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Colors a cell based on the hex value stored in the cell -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub Selection_ColorWithHex() +Sub Selection_ColorWithHex() + '--------------------------------------------------------------------------------------- + ' Procedure : Selection_ColorWithHex + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Colors a cell based on the hex value stored in the cell + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' Dim c As Range - Dim rangeToColor As Range + Dim rngToColor As Range On Error GoTo errHandler - Set rangeToColor = GetInputOrSelection("Select the range of cells to color") + Set rngToColor = GetInputOrSelection("Select the range of cells to color") - For Each c In rangeToColor + For Each c In rngToColor c.Interior.Color = RGB(WorksheetFunction.Hex2Dec(Mid(c.Value, 2, 2)), _ - WorksheetFunction.Hex2Dec(Mid(c.Value, 4, 2)), _ - WorksheetFunction.Hex2Dec(Mid(c.Value, 6, 2))) + WorksheetFunction.Hex2Dec(Mid(c.Value, 4, 2)), _ + WorksheetFunction.Hex2Dec(Mid(c.Value, 6, 2))) Next c Exit Sub @@ -470,15 +468,15 @@ errHandler: MsgBox ("No selection made!") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SplitAndKeep -' Author : @byronwall -' Date : 2015 08 12 -' Purpose : Reduces a cell's value to one item returned from Split -'--------------------------------------------------------------------------------------- -' -Sub SplitAndKeep() +Sub SplitAndKeep() + '--------------------------------------------------------------------------------------- + ' Procedure : SplitAndKeep + ' Author : @byronwall + ' Date : 2015 08 12 + ' Purpose : Reduces a cell's value to one item returned from Split + '--------------------------------------------------------------------------------------- + ' On Error GoTo SplitAndKeep_Error Dim rngToSplit As Range @@ -521,15 +519,15 @@ SplitAndKeep_Error: MsgBox "Check that a valid Range is selected and that a number was entered for which item to keep." End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SplitIntoColumns -' Author : @byronwall, @RaymondWise -' Date : 2015 07 24 -' Purpose : Splits a cell into columns next to it based on a delimeter -'--------------------------------------------------------------------------------------- -' -Sub SplitIntoColumns() +Sub SplitIntoColumns() + '--------------------------------------------------------------------------------------- + ' Procedure : SplitIntoColumns + ' Author : @byronwall, @RaymondWise + ' Date : 2015 07 24 + ' Purpose : Splits a cell into columns next to it based on a delimeter + '--------------------------------------------------------------------------------------- + ' Dim rngInput As Range Set rngInput = GetInputOrSelection("Select the range of cells to split") @@ -559,15 +557,15 @@ errHandler: MsgBox ("No Delimiter Defined!") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SplitIntoRows -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Splits a cell with return characters into multiple rows with no returns -'--------------------------------------------------------------------------------------- -' -Sub SplitIntoRows() +Sub SplitIntoRows() + '--------------------------------------------------------------------------------------- + ' Procedure : SplitIntoRows + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Splits a cell with return characters into multiple rows with no returns + '--------------------------------------------------------------------------------------- + ' Dim rngOutput As Range Dim rngInput As Range @@ -592,22 +590,47 @@ Sub SplitIntoRows() Next c End Sub -'--------------------------------------------------------------------------------------- -' Procedure : TrimSelection -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Trims whitespace from a cell's value -'--------------------------------------------------------------------------------------- -' + Sub TrimSelection() + '--------------------------------------------------------------------------------------- + ' Procedure : TrimSelection + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Trims whitespace from a cell's value + '--------------------------------------------------------------------------------------- + ' Dim rngToTrim As Range On Error GoTo errHandler Set rngToTrim = GetInputOrSelection("Select the formulas you'd like to convert to static values") + + 'disable calcs to speed up + Application.ScreenUpdating = False + Application.EnableEvents = False + Application.Calculation = xlCalculationManual + 'force to only consider used range + Set rngToTrim = Intersect(rngToTrim, rngToTrim.Parent.UsedRange) + Dim c As Range For Each c In rngToTrim - c.Value = Trim(c.Value) + + 'only change if needed + Dim var_trim As Variant + var_trim = Trim(c.Value) + + 'added support for char 160 + 'TODO add more characters to remove + var_trim = Replace(var_trim, Chr(160), "") + + If var_trim <> c.Value Then + c.Value = var_trim + End If Next c + + Application.Calculation = xlCalculationAutomatic + Application.EnableEvents = True + Application.ScreenUpdating = True + Exit Sub errHandler: MsgBox ("No Delimiter Defined!") diff --git a/src/code/RandomCode.bas b/src/code/RandomCode.bas index 52d8ee2..06ff63c 100644 --- a/src/code/RandomCode.bas +++ b/src/code/RandomCode.bas @@ -1,20 +1,182 @@ Attribute VB_Name = "RandomCode" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : RandomCode -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains a lot of junk code that was stored. Most is too specific to be useful. -'--------------------------------------------------------------------------------------- +Sub ExportFilesFromFolder() + '--------------------------------------------------------------------------------------- + ' Procedure : ExportFilesFromFolder + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Goes through a folder and process all workbooks therein + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + '###Needs error handling + 'TODO: consider deleting this Sub since it is quite specific + Application.ScreenUpdating = False + Dim file As Variant + Dim path As String + path = InputBox("What path?") + file = Dir(path) + While (file <> "") + Debug.Print path & file -'''this one goes through a data source and alphabetizes it. -'''keeping mainly for the select case and find/findnext -Sub AlphabetizeAndReportWithDupes() + Dim FileName As String + + FileName = path & file + + Dim wbActive As Workbook + Set wbActive = Workbooks.Open(FileName) + + Dim wsActive As Worksheet + Set wsActive = wbActive.Sheets("Case Summary") + + With ActiveSheet.PageSetup + .TopMargin = Application.InchesToPoints(0.4) + .BottomMargin = Application.InchesToPoints(0.4) + End With + + wsActive.ExportAsFixedFormat xlTypePDF, path & "PDFs\" & file & ".pdf" + + wbActive.Close False + + file = Dir + Wend + + Application.ScreenUpdating = True + +End Sub + +Sub EvaluateArrayFormulaOnNewSheet() + '--------------------------------------------------------------------------------------- + ' Procedure : EvaluateArrayFormulaOnNewSheet + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Wacky thing to force an array formula to return as an array + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + 'cut cell with formula + Dim StrAddress As String + Dim rngStart As Range + Set rngStart = Sheet1.Range("J2") + StrAddress = rngStart.Address + + rngStart.Cut + + 'create new sheet + Dim sht As Worksheet + Set sht = Worksheets.Add + + 'paste cell onto sheet + Dim rngArr As Range + Set rngArr = sht.Range("A1") + sht.Paste rngArr + + 'expand array formula size.. resize to whatever size is needed + rngArr.Resize(3).FormulaArray = rngArr.FormulaArray + + 'get your result + Dim VarArr As Variant + VarArr = Application.Evaluate(rngArr.CurrentArray.Address) + + ''''do something with your result here... it is an array + + + 'shrink the formula back to one cell + Dim strFormula As String + strFormula = rngArr.FormulaArray + + rngArr.CurrentArray.ClearContents + rngArr.FormulaArray = strFormula + + 'cut and paste back to original spot + rngArr.Cut + + Sheet1.Paste Sheet1.Range(StrAddress) + + Application.DisplayAlerts = False + sht.Delete + Application.DisplayAlerts = True + +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 Long + + 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 + +Sub CreatePdfOfEachXlsxFileInFolder() + + 'pick a folder + Dim folderDialog As FileDialog + Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker) + + folderDialog.Show + + Dim folderPath As String + folderPath = folderDialog.SelectedItems(1) & "\" + + 'find all files in the folder + Dim filePath As String + filePath = Dir(folderPath & "*.xlsx") + + Do While filePath <> "" + + Dim wkbkFile As Workbook + Set wkbkFile = Workbooks.Open(folderPath & filePath, , True) + + Dim sht As Worksheet + + For Each sht In wkbkFile.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 + + wkbkFile.ExportAsFixedFormat xlTypePDF, folderPath & filePath & ".pdf" + wkbkFile.Close False + + filePath = Dir + Loop +End Sub + +Sub AlphabetizeAndReportWithDupes() + '''this one goes through a data source and alphabetizes it. + '''keeping mainly for the select case and find/findnext Dim rng_data As Range Set rng_data = Range("B2:B28") @@ -32,10 +194,10 @@ Sub AlphabetizeAndReportWithDupes() 'if duplicate, use FindNext, else just Find Dim rng_search As Range Select Case True - Case i = LBound(arr), UCase(arr(i)) <> UCase(arr(i - 1)) - Set rng_search = rng_data.Find(arr(i)) - Case Else - Set rng_search = rng_data.FindNext(rng_search) + Case i = LBound(arr), UCase(arr(i)) <> UCase(arr(i - 1)) + Set rng_search = rng_data.Find(arr(i)) + Case Else + Set rng_search = rng_data.FindNext(rng_search) End Select ''''do your report stuff in here for each row @@ -91,7 +253,7 @@ Sub Rand_PrintMultiple() 'Another static folder Dim rng_tag As Range Dim str_path As String - str_path = "C:\Documents and Settings\wallbd\Application Data\PDF OUTPUT\" + str_path = InputBox("Provide a folder for output location") For Each rng_tag In Range("TAGS[TAG]").SpecialCells(xlCellTypeVisible) @@ -126,7 +288,7 @@ Sub Rand_PrintMultiplePvVsOp() 'Another static folder Dim rng_tag As Range Dim str_path As String - str_path = "C:\Documents and Settings\wallbd\Application Data\PDF OUTPUT\" + str_path = InputBox("Provide a folder for output location") For Each rng_tag In Range("tag_table[TAG]").SpecialCells(xlCellTypeVisible) @@ -140,27 +302,50 @@ Sub Rand_PrintMultiplePvVsOp() End Sub +Function DownloadFileAsString(ByVal vWebFile As String) As String + Dim oXMLHTTP As Object, i As Long, vFF As Long, oResp() As Byte + + 'You can also set a ref. to Microsoft XML, and Dim oXMLHTTP as MSXML2.XMLHTTP + Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP.6.0") + oXMLHTTP.Open "GET", vWebFile, False 'Open socket to get the website + oXMLHTTP.Send 'send request + + 'Wait for request to finish + Do While oXMLHTTP.readyState <> 4 + DoEvents + Loop + + DownloadFileAsString = oXMLHTTP.responseText 'Returns the results as a byte array + + 'Clear memory + Set oXMLHTTP = Nothing +End Function + Function Download_File(ByVal vWebFile As String, ByVal vLocalFile As String) As Boolean Dim oXMLHTTP As Object, i As Long, vFF As Long, oResp() As Byte 'You can also set a ref. to Microsoft XML, and Dim oXMLHTTP as MSXML2.XMLHTTP - Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") - oXMLHTTP.Open "GET", vWebFile, False 'Open socket to get the website - oXMLHTTP.Send 'send request + Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP.6.0") + oXMLHTTP.Open "GET", vWebFile, False 'Open socket to get the website + oXMLHTTP.Send 'send request 'Wait for request to finish Do While oXMLHTTP.readyState <> 4 - DoEvents + DoEvents Loop - oResp = oXMLHTTP.responseBody 'Returns the results as a byte array + oResp = oXMLHTTP.responseBody 'Returns the results as a byte array 'Create local file and save results to it - vFF = FreeFile - If Dir(vLocalFile) <> "" Then Kill vLocalFile - Open vLocalFile For Binary As #vFF - Put #vFF, , oResp - Close #vFF + Dim oStream As Object + If oXMLHTTP.Status = 200 Then + Set oStream = CreateObject("ADODB.Stream") + oStream.Open + oStream.Type = 1 + oStream.Write oXMLHTTP.responseBody + oStream.SaveToFile vLocalFile, 2 ' 1 = no overwrite, 2 = overwrite + oStream.Close + End If 'Clear memory Set oXMLHTTP = Nothing @@ -172,7 +357,7 @@ Sub Rand_DownloadFromSheet() Dim str_folder As Variant 'Another static folder - str_folder = "C:\Documents and Settings\wallbd\Application Data\DSP Guide\" + str_folder = InputBox("Provide a folder location for output") For Each rng_addr In Range("B2:B35") @@ -184,62 +369,62 @@ End Sub Sub Rand_CommonPrintSettings() -Application.ScreenUpdating = False -Dim sht As Worksheet - -For Each sht In Sheets - sht.PageSetup.PrintArea = "" - sht.ResetAllPageBreaks - sht.PageSetup.PrintArea = "" - - With sht.PageSetup - .LeftHeader = "" - .CenterHeader = "" - .RightHeader = "" - .LeftFooter = "" - .CenterFooter = "" - .RightFooter = "" - .LeftMargin = Application.InchesToPoints(0.75) - .RightMargin = Application.InchesToPoints(0.75) - .TopMargin = Application.InchesToPoints(1) - .BottomMargin = Application.InchesToPoints(1) - .HeaderMargin = Application.InchesToPoints(0.5) - .FooterMargin = Application.InchesToPoints(0.5) - .PrintHeadings = False - .PrintGridlines = False - .PrintComments = xlPrintNoComments - .PrintQuality = 600 - .CenterHorizontally = False - .CenterVertically = False - .Orientation = xlLandscape - .Draft = False - .PaperSize = xlPaperLetter - .FirstPageNumber = xlAutomatic - .Order = xlDownThenOver - .BlackAndWhite = False - .Zoom = False - .FitToPagesWide = 1 - .FitToPagesTall = False - .PrintErrors = xlPrintErrorsDisplayed - .OddAndEvenPagesHeaderFooter = False - .DifferentFirstPageHeaderFooter = False - .ScaleWithDocHeaderFooter = True - .AlignMarginsHeaderFooter = False - .EvenPage.LeftHeader.Text = "" - .EvenPage.CenterHeader.Text = "" - .EvenPage.RightHeader.Text = "" - .EvenPage.LeftFooter.Text = "" - .EvenPage.CenterFooter.Text = "" - .EvenPage.RightFooter.Text = "" - .FirstPage.LeftHeader.Text = "" - .FirstPage.CenterHeader.Text = "" - .FirstPage.RightHeader.Text = "" - .FirstPage.LeftFooter.Text = "" - .FirstPage.CenterFooter.Text = "" - .FirstPage.RightFooter.Text = "" - .PrintTitleRows = "" - .PrintTitleColumns = "" - End With + Application.ScreenUpdating = False + Dim sht As Worksheet + + For Each sht In Sheets + sht.PageSetup.PrintArea = "" + sht.ResetAllPageBreaks + sht.PageSetup.PrintArea = "" + + With sht.PageSetup + .LeftHeader = "" + .CenterHeader = "" + .RightHeader = "" + .LeftFooter = "" + .CenterFooter = "" + .RightFooter = "" + .LeftMargin = Application.InchesToPoints(0.75) + .RightMargin = Application.InchesToPoints(0.75) + .TopMargin = Application.InchesToPoints(1) + .BottomMargin = Application.InchesToPoints(1) + .HeaderMargin = Application.InchesToPoints(0.5) + .FooterMargin = Application.InchesToPoints(0.5) + .PrintHeadings = False + .PrintGridlines = False + .PrintComments = xlPrintNoComments + .PrintQuality = 600 + .CenterHorizontally = False + .CenterVertically = False + .Orientation = xlLandscape + .Draft = False + .PaperSize = xlPaperLetter + .FirstPageNumber = xlAutomatic + .Order = xlDownThenOver + .BlackAndWhite = False + .Zoom = False + .FitToPagesWide = 1 + .FitToPagesTall = False + .PrintErrors = xlPrintErrorsDisplayed + .OddAndEvenPagesHeaderFooter = False + .DifferentFirstPageHeaderFooter = False + .ScaleWithDocHeaderFooter = True + .AlignMarginsHeaderFooter = False + .EvenPage.LeftHeader.Text = "" + .EvenPage.CenterHeader.Text = "" + .EvenPage.RightHeader.Text = "" + .EvenPage.LeftFooter.Text = "" + .EvenPage.CenterFooter.Text = "" + .EvenPage.RightFooter.Text = "" + .FirstPage.LeftHeader.Text = "" + .FirstPage.CenterHeader.Text = "" + .FirstPage.RightHeader.Text = "" + .FirstPage.LeftFooter.Text = "" + .FirstPage.CenterFooter.Text = "" + .FirstPage.RightFooter.Text = "" + .PrintTitleRows = "" + .PrintTitleColumns = "" + End With Next sht Application.ScreenUpdating = True @@ -264,12 +449,12 @@ Sub Rand_DumpTextFromAllSheets() Set w = Application.Workbooks.Add Set sw = w.Sheets.Add - Dim row As Long - row = 0 + Dim Row As Long + Row = 0 For Each s In main.Sheets For Each c In s.UsedRange.SpecialCells(xlCellTypeConstants) - sw.Range("A1").Offset(row) = c - row = row + 1 + sw.Range("A1").Offset(Row) = c + Row = Row + 1 Next c Next s @@ -294,9 +479,9 @@ Sub Rand_ApplyHeadersAndFootersToAll() End Sub -'Takes a table of values and flattens it. -Sub Rand_Matrix() +Sub Rand_Matrix() + 'Takes a table of values and flattens it. Dim rng_left As Range Dim rng_top As Range Dim rng_body As Range @@ -306,8 +491,8 @@ Sub Rand_Matrix() Dim int_left As Long, int_top As Long - Set rng_body = Range(Cells(rng_left.row, rng_top.Column), _ - Cells(rng_left.Rows(rng_left.Rows.count).row, rng_top.Columns(rng_top.Columns.count).Column)) + Set rng_body = Range(Cells(rng_left.Row, rng_top.Column), _ + Cells(rng_left.Rows(rng_left.Rows.count).Row, rng_top.Columns(rng_top.Columns.count).Column)) Dim sht_out As Worksheet Set sht_out = Application.Worksheets.Add() @@ -318,7 +503,7 @@ Sub Rand_Matrix() int_row = 1 For Each rng_cell In rng_body.SpecialCells(xlCellTypeConstants) - sht_out.Range("A1").Offset(int_row) = rng_left.Cells(rng_cell.row - rng_left.row + 1, 1) + sht_out.Range("A1").Offset(int_row) = rng_left.Cells(rng_cell.Row - rng_left.Row + 1, 1) sht_out.Range("B1").Offset(int_row) = rng_top.Cells(1, rng_cell.Column - rng_top.Column + 1) sht_out.Range("C1").Offset(int_row) = rng_cell diff --git a/src/code/Ribbon_Callbacks.bas b/src/code/Ribbon_Callbacks.bas index 42ce4dc..67dfc4a 100644 --- a/src/code/Ribbon_Callbacks.bas +++ b/src/code/Ribbon_Callbacks.bas @@ -1,18 +1,11 @@ Attribute VB_Name = "Ribbon_Callbacks" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Ribbon_Callbacks -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains all of the callbacks used by the Ribbon XML file -'--------------------------------------------------------------------------------------- - Dim frm_chartGrid As New form_chtGrid Public Sub btn_aboutForm_onAction(control As IRibbonControl) -'catch the rare case where the add-in is opened directly + 'catch the rare case where the add-in is opened directly If ActiveWorkbook Is Nothing Then Application.Workbooks.Add End If @@ -171,11 +164,10 @@ Public Sub btn_seriesSplit_onAction(control As IRibbonControl) SeriesSplit End Sub -' Sub btn_sheetDeleteHiddenRows_onAction(control As IRibbonControl) Sheet_DeleteHiddenRows End Sub -' + Public Sub btn_sheetNamesOutput_onAction(control As IRibbonControl) OutputSheets @@ -217,15 +209,19 @@ Public Sub btn_updateScrollbars_onAction(control As IRibbonControl) UpdateScrollbars End Sub -'--------------------------------------------------------------------------------------- -' Procedure : RibbonOnLoad -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : OnLoad entry point for the add-in -'--------------------------------------------------------------------------------------- -' -Public Sub RibbonOnLoad(ribbon As IRibbonUI) +Public Sub btn_checkUpdates_onAction(control As IRibbonControl) + CheckForUpdates +End Sub + +Public Sub RibbonOnLoad(ribbon As IRibbonUI) + '--------------------------------------------------------------------------------------- + ' Procedure : RibbonOnLoad + ' Author : @byronwall + ' Date : 2015 08 05 + ' Purpose : OnLoad entry point for the add-in + '--------------------------------------------------------------------------------------- + ' SetUpKeyboardHooksForSelection End Sub diff --git a/src/code/SelectionMgr.bas b/src/code/SelectionMgr.bas index c63a28d..8337feb 100644 --- a/src/code/SelectionMgr.bas +++ b/src/code/SelectionMgr.bas @@ -1,28 +1,21 @@ Attribute VB_Name = "SelectionMgr" -'--------------------------------------------------------------------------------------- -' Module : SelectionMgr -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : This module contains code related to changing the Selection with kbd shortcuts -'--------------------------------------------------------------------------------------- - Option Explicit -'--------------------------------------------------------------------------------------- -' Procedure : OffsetSelectionByRowsAndColumns -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : Offsets and selects the Selection a given number of rows/columns -'--------------------------------------------------------------------------------------- -' -Sub OffsetSelectionByRowsAndColumns(rowsOff As Long, columnsOff As Long) +Sub OffsetSelectionByRowsAndColumns(iRowsOff As Long, iColsOff As Long) + '--------------------------------------------------------------------------------------- + ' Procedure : OffsetSelectionByRowsAndColumns + ' Author : @byronwall + ' Date : 2015 08 05 + ' Purpose : Offsets and selects the Selection a given number of rows/columns + '--------------------------------------------------------------------------------------- + ' If TypeOf Selection Is Range Then 'this error should only get called if the new range is outside the sheet boundaries On Error GoTo OffsetSelectionByRowsAndColumns_Exit - Selection.Offset(rowsOff, columnsOff).Select + Selection.Offset(iRowsOff, iColsOff).Select On Error GoTo 0 End If @@ -31,71 +24,81 @@ OffsetSelectionByRowsAndColumns_Exit: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SelectionOffsetDown -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : Moves Selection down one row -'--------------------------------------------------------------------------------------- -' -Sub SelectionOffsetDown() +Sub SelectionOffsetDown() + '--------------------------------------------------------------------------------------- + ' Procedure : SelectionOffsetDown + ' Author : @byronwall + ' Date : 2015 08 05 + ' Purpose : Moves Selection down one row + '--------------------------------------------------------------------------------------- + ' Call OffsetSelectionByRowsAndColumns(1, 0) End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SelectionOffsetLeft -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : Moves Selection left one column -'--------------------------------------------------------------------------------------- -' -Sub SelectionOffsetLeft() +Sub SelectionOffsetLeft() + '--------------------------------------------------------------------------------------- + ' Procedure : SelectionOffsetLeft + ' Author : @byronwall + ' Date : 2015 08 05 + ' Purpose : Moves Selection left one column + '--------------------------------------------------------------------------------------- + ' Call OffsetSelectionByRowsAndColumns(0, -1) End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SelectionOffsetRight -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : Moves selection right one column -'--------------------------------------------------------------------------------------- -' -Sub SelectionOffsetRight() +Sub SelectionOffsetRight() + '--------------------------------------------------------------------------------------- + ' Procedure : SelectionOffsetRight + ' Author : @byronwall + ' Date : 2015 08 05 + ' Purpose : Moves selection right one column + '--------------------------------------------------------------------------------------- + ' Call OffsetSelectionByRowsAndColumns(0, 1) End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SelectionOffsetUp -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : Moves Selection up one row -'--------------------------------------------------------------------------------------- -' -Sub SelectionOffsetUp() +Sub SelectionOffsetUp() + '--------------------------------------------------------------------------------------- + ' Procedure : SelectionOffsetUp + ' Author : @byronwall + ' Date : 2015 08 05 + ' Purpose : Moves Selection up one row + '--------------------------------------------------------------------------------------- + ' Call OffsetSelectionByRowsAndColumns(-1, 0) End Sub -'--------------------------------------------------------------------------------------- -' Procedure : SetUpKeyboardHooksForSelection -' Author : @byronwall -' Date : 2015 08 05 -' Purpose : Creates hotkey events for the selection events -'--------------------------------------------------------------------------------------- -' -Sub SetUpKeyboardHooksForSelection() +Sub SetUpKeyboardHooksForSelection() + '--------------------------------------------------------------------------------------- + ' Procedure : SetUpKeyboardHooksForSelection + ' Author : @byronwall + ' Date : 2016 09 29 + ' Purpose : Creates hotkey events for the selection events + '--------------------------------------------------------------------------------------- + ' + + 'SHIFT = + + 'CTRL = ^ + 'ALT = % + + 'set up the keys for the selection mover Application.OnKey "^%{RIGHT}", "SelectionOffsetRight" Application.OnKey "^%{LEFT}", "SelectionOffsetLeft" Application.OnKey "^%{UP}", "SelectionOffsetUp" Application.OnKey "^%{DOWN}", "SelectionOffsetDown" + + 'set up the keys for the indent level + Application.OnKey "+^%{RIGHT}", "Formatting_IncreaseIndentLevel" + Application.OnKey "+^%{LEFT}", "Formatting_DecreaseIndentLevel" End Sub diff --git a/src/code/Sheet_Helpers.bas b/src/code/Sheet_Helpers.bas index 0ae37bb..28c2463 100644 --- a/src/code/Sheet_Helpers.bas +++ b/src/code/Sheet_Helpers.bas @@ -1,22 +1,15 @@ Attribute VB_Name = "Sheet_Helpers" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Sheet_Helpers -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains code related to sheets and sheet processing -'--------------------------------------------------------------------------------------- - -'--------------------------------------------------------------------------------------- -' Procedure : LockAllSheets -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Locks all sheets with the same password -'--------------------------------------------------------------------------------------- -' -Sub LockAllSheets() +Sub LockAllSheets() + '--------------------------------------------------------------------------------------- + ' Procedure : LockAllSheets + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Locks all sheets with the same password + '--------------------------------------------------------------------------------------- + ' Dim pass As Variant pass = Application.InputBox("Password to lock") @@ -37,50 +30,50 @@ Sub LockAllSheets() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : OutputSheets -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Creates a new worksheet with a list and link to each sheet -'--------------------------------------------------------------------------------------- -' -Sub OutputSheets() - - Dim newSheet As Worksheet - Set newSheet = Worksheets.Add(Before:=Worksheets(1)) - newSheet.Activate - - Dim newRange As Range - Set newRange = newSheet.Range("B2") - - Dim row As Long - row = 0 - - Dim mySheet As Worksheet - For Each mySheet In Worksheets - If mySheet.name <> newSheet.name Then - - mySheet.Hyperlinks.Add _ - newRange.Offset(row), "", _ - "'" & mySheet.name & "'!A1", , _ - mySheet.name - row = row + 1 +Sub OutputSheets() + '--------------------------------------------------------------------------------------- + ' Procedure : OutputSheets + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Creates a new worksheet with a list and link to each sheet + '--------------------------------------------------------------------------------------- + ' + Dim wsOut As Worksheet + Set wsOut = Worksheets.Add(Before:=Worksheets(1)) + wsOut.Activate + + Dim rngOut As Range + Set rngOut = wsOut.Range("B2") + + Dim iRow As Long + iRow = 0 + + Dim sht As Worksheet + For Each sht In Worksheets + + If sht.name <> wsOut.name Then + + sht.Hyperlinks.Add _ + rngOut.Offset(iRow), "", _ + "'" & sht.name & "'!A1", , _ + sht.name + iRow = iRow + 1 End If - Next mySheet + Next sht End Sub -'--------------------------------------------------------------------------------------- -' Procedure : UnlockAllSheets -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Unlocks all sheets with the same password -'--------------------------------------------------------------------------------------- -' -Sub UnlockAllSheets() +Sub UnlockAllSheets() + '--------------------------------------------------------------------------------------- + ' Procedure : UnlockAllSheets + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Unlocks all sheets with the same password + '--------------------------------------------------------------------------------------- + ' Dim pass As Variant pass = Application.InputBox("Password to unlock") @@ -92,79 +85,81 @@ Sub UnlockAllSheets() Else Application.ScreenUpdating = False 'Changed to activeworkbook so if add-in is not installed, it will target the active book rather than the xlam - Dim mySheet As Worksheet - For Each mySheet In ActiveWorkbook.Sheets + Dim sht As Worksheet + For Each sht In ActiveWorkbook.Sheets 'Let's keep track of the errors to inform the user If Err.Number <> 0 Then iErr = iErr + 1 Err.Clear On Error Resume Next - mySheet.Unprotect (pass) + sht.Unprotect (pass) - Next mySheet + Next sht If Err.Number <> 0 Then iErr = iErr + 1 Application.ScreenUpdating = True End If If iErr <> 0 Then - MsgBox (iErr & " sheets could not be unlocked due to bad password.") + MsgBox (iErr & " sheets could not be unlocked due to bad password.") End If End Sub -'--------------------------------------------------------------------------------------- -' Procedure : AscendSheets -' Author : @raymondwise -' Date : 2015 08 07 -' Purpose : Places worksheets in ascending alphabetical order. -'--------------------------------------------------------------------------------------- + Sub AscendSheets() -Application.ScreenUpdating = False -Dim myBook As Workbook -Set myBook = ActiveWorkbook - -Dim numberOfSheets As Long -numberOfSheets = myBook.Sheets.count - -Dim i As Long -Dim j As Long - -With myBook - For j = 1 To numberOfSheets - For i = 1 To numberOfSheets - 1 - If UCase(.Sheets(i).name) > UCase(.Sheets(i + 1).name) Then - .Sheets(i).Move after:=.Sheets(i + 1) - End If - Next i - Next j -End With - -Application.ScreenUpdating = True + '--------------------------------------------------------------------------------------- + ' Procedure : AscendSheets + ' Author : @raymondwise + ' Date : 2015 08 07 + ' Purpose : Places worksheets in ascending alphabetical order. + '--------------------------------------------------------------------------------------- + Application.ScreenUpdating = False + Dim wb As Workbook + Set wb = ActiveWorkbook + + Dim intSheets As Long + intSheets = wb.Sheets.count + + Dim i As Long + Dim j As Long + + With wb + For j = 1 To intSheets + For i = 1 To intSheets - 1 + If UCase(.Sheets(i).name) > UCase(.Sheets(i + 1).name) Then + .Sheets(i).Move after:=.Sheets(i + 1) + End If + Next i + Next j + End With + + Application.ScreenUpdating = True End Sub -'--------------------------------------------------------------------------------------- -' Procedure : DescendSheets -' Author : @raymondwise -' Date : 2015 08 07 -' Purpose : Places worksheets in descending alphabetical order. -'--------------------------------------------------------------------------------------- + Sub DescendSheets() -Application.ScreenUpdating = False -Dim myBook As Workbook -Set myBook = ActiveWorkbook - -Dim numberOfSheets As Long -numberOfSheets = myBook.Sheets.count - -Dim i As Long -Dim j As Long - -With myBook - For j = 1 To numberOfSheets - For i = 1 To numberOfSheets - 1 - If UCase(.Sheets(i).name) < UCase(.Sheets(i + 1).name) Then - .Sheets(i).Move after:=.Sheets(i + 1) - End If - Next i - Next j -End With - -Application.ScreenUpdating = True + '--------------------------------------------------------------------------------------- + ' Procedure : DescendSheets + ' Author : @raymondwise + ' Date : 2015 08 07 + ' Purpose : Places worksheets in descending alphabetical order. + '--------------------------------------------------------------------------------------- + Application.ScreenUpdating = False + Dim wb As Workbook + Set wb = ActiveWorkbook + + Dim intSheets As Long + intSheets = wb.Sheets.count + + Dim i As Long + Dim j As Long + + With wb + For j = 1 To intSheets + For i = 1 To intSheets - 1 + If UCase(.Sheets(i).name) < UCase(.Sheets(i + 1).name) Then + .Sheets(i).Move after:=.Sheets(i + 1) + End If + Next i + Next j + End With + + Application.ScreenUpdating = True End Sub diff --git a/src/code/SubsFuncs_Helpers.bas b/src/code/SubsFuncs_Helpers.bas index 75c9a25..920a415 100644 --- a/src/code/SubsFuncs_Helpers.bas +++ b/src/code/SubsFuncs_Helpers.bas @@ -1,30 +1,23 @@ Attribute VB_Name = "SubsFuncs_Helpers" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : SubsFuncs_Helpers -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains some common helper code across the add-in -'--------------------------------------------------------------------------------------- - -'--------------------------------------------------------------------------------------- -' Procedure : GetInputOrSelection -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Provides a single Function to get the Selection or Input with error handling -'--------------------------------------------------------------------------------------- -' + Function GetInputOrSelection(msg As String) As Range - - Dim defaultString As String + '--------------------------------------------------------------------------------------- + ' Procedure : GetInputOrSelection + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Provides a single Function to get the Selection or Input with error handling + '--------------------------------------------------------------------------------------- + ' + Dim strDefault As String If TypeOf Selection Is Range Then - defaultString = Selection.Address + strDefault = Selection.Address End If On Error GoTo ErrorNoSelection - Set GetInputOrSelection = Application.InputBox(msg, Type:=8, Default:=defaultString) + Set GetInputOrSelection = Application.InputBox(msg, Type:=8, Default:=strDefault) Exit Function @@ -34,89 +27,89 @@ ErrorNoSelection: End Function -'--------------------------------------------------------------------------------------- -' Procedure : RangeEnd -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Helper function to return a block of cells using a starting Range and an End direction -'--------------------------------------------------------------------------------------- -' -Function RangeEnd(start As Range, firstDirection As XlDirection, Optional secondDirection As XlDirection = -1) As Range - If secondDirection = -1 Then - Set RangeEnd = Range(start, start.End(firstDirection)) +Function RangeEnd(start As Range, direction As XlDirection, Optional direction2 As XlDirection = -1) As Range + '--------------------------------------------------------------------------------------- + ' Procedure : RangeEnd + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Helper function to return a block of cells using a starting Range and an End direction + '--------------------------------------------------------------------------------------- + ' + If direction2 = -1 Then + Set RangeEnd = Range(start, start.End(direction)) Else - Set RangeEnd = Range(start, start.End(firstDirection).End(secondDirection)) + Set RangeEnd = Range(start, start.End(direction).End(direction2)) End If End Function -'--------------------------------------------------------------------------------------- -' Procedure : RangeEnd_Boundary -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Helper function to return a range limited by the starting cell's CurrentRegion -'--------------------------------------------------------------------------------------- -' -Function RangeEnd_Boundary(start As Range, firstDirection As XlDirection, Optional secondDirection As XlDirection = -1) As Range - - If secondDirection = -1 Then - Set RangeEnd_Boundary = Intersect(Range(start, start.End(firstDirection)), start.CurrentRegion) + +Function RangeEnd_Boundary(start As Range, direction As XlDirection, Optional direction2 As XlDirection = -1) As Range + '--------------------------------------------------------------------------------------- + ' Procedure : RangeEnd_Boundary + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Helper function to return a range limited by the starting cell's CurrentRegion + '--------------------------------------------------------------------------------------- + ' + If direction2 = -1 Then + Set RangeEnd_Boundary = Intersect(Range(start, start.End(direction)), start.CurrentRegion) Else - Set RangeEnd_Boundary = Intersect(Range(start, start.End(firstDirection).End(secondDirection)), start.CurrentRegion) + Set RangeEnd_Boundary = Intersect(Range(start, start.End(direction).End(direction2)), start.CurrentRegion) End If End Function -'--------------------------------------------------------------------------------------- -' Procedure : QuickSort -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Sorting implementation for arrays -' Source : http://stackoverflow.com/a/152325/4288101 -' http://en.allexperts.com/q/Visual-Basic-1048/string-manipulation.htm -'--------------------------------------------------------------------------------------- -' -Public Sub QuickSort(vArray As Variant, Optional incomingLB As Variant, Optional incomingUB As Variant) +Public Sub QuickSort(vArray As Variant, Optional inLow As Variant, Optional inHi As Variant) + '--------------------------------------------------------------------------------------- + ' Procedure : QuickSort + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Sorting implementation for arrays + ' Source : http://stackoverflow.com/a/152325/4288101 + ' http://en.allexperts.com/q/Visual-Basic-1048/string-manipulation.htm + '--------------------------------------------------------------------------------------- + ' Dim pivot As Variant Dim tmpSwap As Variant - Dim tempLB As Long - Dim tempUB As Long + Dim tmpLow As Long + Dim tmpHi As Long - If IsMissing(incomingLB) Then - incomingLB = LBound(vArray) + If IsMissing(inLow) Then + inLow = LBound(vArray) End If - If IsMissing(incomingUB) Then - incomingUB = UBound(vArray) + If IsMissing(inHi) Then + inHi = UBound(vArray) End If - tempLB = incomingLB - tempUB = incomingUB + tmpLow = inLow + tmpHi = inHi - pivot = vArray((incomingLB + incomingUB) \ 2) + pivot = vArray((inLow + inHi) \ 2) - While (tempLB <= tempUB) + While (tmpLow <= tmpHi) - While (UCase(vArray(tempLB)) < UCase(pivot) And tempLB < incomingUB) - tempLB = tempLB + 1 + While (UCase(vArray(tmpLow)) < UCase(pivot) And tmpLow < inHi) + tmpLow = tmpLow + 1 Wend - While (UCase(pivot) < UCase(vArray(tempUB)) And tempUB > incomingLB) - tempUB = tempUB - 1 + While (UCase(pivot) < UCase(vArray(tmpHi)) And tmpHi > inLow) + tmpHi = tmpHi - 1 Wend - If (tempLB <= tempUB) Then - tmpSwap = vArray(tempLB) - vArray(tempLB) = vArray(tempUB) - vArray(tempUB) = tmpSwap - tempLB = tempLB + 1 - tempUB = tempUB - 1 + If (tmpLow <= tmpHi) Then + tmpSwap = vArray(tmpLow) + vArray(tmpLow) = vArray(tmpHi) + vArray(tmpHi) = tmpSwap + tmpLow = tmpLow + 1 + tmpHi = tmpHi - 1 End If Wend - If (incomingLB < tempUB) Then QuickSort vArray, incomingLB, tempUB - If (tempLB < incomingUB) Then QuickSort vArray, tempLB, incomingUB + If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi + If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi End Sub diff --git a/src/code/Testing.bas b/src/code/Testing.bas index 894ccf8..bc147e8 100644 --- a/src/code/Testing.bas +++ b/src/code/Testing.bas @@ -1,14 +1,475 @@ Attribute VB_Name = "Testing" Option Explicit +'Testing module contains code that is not in a final state +'It is a proving ground for code that will eventually be a part of the add-in + +Public Sub FormulaModifier() + + 'this works for the single case where formula is =A+B + 'it will substitute the constituent formulas for A & B + 'this does not work in the general case at all + + 'get the current formula + Dim rngCell As Range + For Each rngCell In Selection + + 'remove the first = + Dim strForm As String + strForm = rngCell.Formula + + strForm = Right(strForm, Len(strForm) - 1) + + 'split based on + sign + Dim parts As Variant + parts = Split(strForm, "+") + + Dim newParts() As String + ReDim newParts(UBound(parts)) + + Dim index As Long + For index = LBound(parts) To UBound(parts) + Dim strPartForm As String + strPartForm = Range(parts(index)).Formula + newParts(index) = Right(strPartForm, Len(strPartForm) - 1) + Next + + Dim strNewForm As String + strNewForm = "=" & Join(newParts, "+") + + 'get the cells and parse their formulas + + rngCell.Formula = strNewForm + Next + + 'stick those formulas into the current one + +End Sub + +Public Sub ListAllPossiblePlacesForExternalReferences() + + 'search through chart formulas + Debug.Print "Checking chart series formulas..." + Dim chtObj As ChartObject + For Each chtObj In Chart_GetObjectsFromObject(ActiveSheet) + Dim ser As series + For Each ser In chtObj.Chart.SeriesCollection + + Dim strForm As String + strForm = ser.Formula + + If InStr(strForm, "[") Then + Debug.Print strForm + End If + Next + Next + + 'search in data validation + Dim sht As Worksheet + Dim rng As Range + Debug.Print "Checking data validation formulas..." + For Each sht In Worksheets + For Each rng In sht.UsedRange + Dim strVal As String + strVal = "!" + On Error Resume Next + strVal = rng.Validation.Formula1 + On Error GoTo 0 + + If strVal <> "!" Then + If InStr(strVal, "[") Then + Debug.Print rng.Address(False, False, , True) & strVal + 'rng.Activate + End If + End If + Next + Next + + 'search in conditional formatting + Debug.Print "Checking conditional formatting formulas..." + For Each sht In Worksheets + For Each rng In sht.UsedRange + Dim condFormat As FormatCondition + For Each condFormat In rng.FormatConditions + 'get the formulas + + strVal = "!" + On Error Resume Next + strVal = condFormat.Formula1 + On Error GoTo 0 + + If strVal <> "!" Then + If InStr(strVal, "[") Then + Debug.Print rng.Address(False, False, , True) & strVal + 'rng.Activate + End If + End If + Next + Next + Next +End Sub + +Sub Formatting_IncreaseIndentLevel() + + Dim rngCell As Range + + For Each rngCell In Selection + rngCell.IndentLevel = rngCell.IndentLevel + 2 + Next + +End Sub + +Sub Formatting_DecreaseIndentLevel() + + Dim rngCell As Range + + For Each rngCell In Selection + rngCell.IndentLevel = WorksheetFunction.Max(rngCell.IndentLevel - 2, 0) + Next + +End Sub + +Sub ShowOtherOpenInstanceOfExcel() + Dim oXLApp As Object + + 'this will work if the previous instance was opened before the current one + + On Error Resume Next + Set oXLApp = GetObject(, "Excel.Application") + On Error GoTo 0 + + oXLApp.Visible = True + + Set oXLApp = Nothing +End Sub + +Sub PadWithSpaces() + + 'quick and dirty function to add a bunch of spaces to the end of the ActiveCell + + Dim lng_spaces As Long + lng_spaces = InputBox("How many spaces?") + + ActiveCell.Value = ActiveCell.Value & WorksheetFunction.Rept(" ", lng_spaces) + +End Sub + +Public Sub PushMergeFieldsIntoPowerPoint() + + Dim strPath As String + strPath = InputBox("Provide the filename pptx to check") + + Dim appPPT As New PowerPoint.Application + + Dim presTemplate As Presentation + Set presTemplate = appPPT.Presentations.Open(strPath) + + 'create a new presentation + + Dim presNew As Presentation + Set presNew = appPPT.Presentations.Add() + + 'for each row in the table + Dim rngData As Range + Set rngData = Range("Table1") + + Dim rngHeaders As Range + Set rngHeaders = Range("A1") + Set rngHeaders = Range(rngHeaders, rngHeaders.End(xlToRight)) + + presNew.ApplyTemplate (presTemplate.FullName) + + Dim rngRow As Range + For Each rngRow In rngData.Rows + 'copy the template slide to end + presTemplate.Slides(1).Copy + presNew.Slides.Paste + + Dim oSld As slide + Set oSld = presNew.Slides(presNew.Slides.count) + + Dim oShp As PowerPoint.Shape + Dim oTxtRng As PowerPoint.TextRange + Dim oTmpRng As PowerPoint.TextRange + + Dim rngHeader As Range + For Each rngHeader In rngHeaders + + Dim strFind As String + Dim strReplace As String + + strFind = rngHeader.Value + strReplace = rngRow.Cells(1, rngHeader.Column).Value + + For Each oShp In oSld.Shapes + + If oShp.HasTextFrame Then + Set oTxtRng = oShp.TextFrame.TextRange + + Set oTmpRng = oTxtRng.Replace(FindWhat:=strFind, _ + Replacewhat:=strReplace, WholeWords:=False) + + Do While Not oTmpRng Is Nothing + + Set oTxtRng = oTxtRng.Characters(oTmpRng.start + oTmpRng.Length, _ + oTxtRng.Length) + + Set oTmpRng = oTxtRng.Replace(FindWhat:=strFind, _ + Replacewhat:=strReplace, WholeWords:=False) + + Loop + End If + + Next oShp + Next + 'search for each header and replace values + Next + + presTemplate.Close + +End Sub + +Public Sub GetListOfMacrosCalledByButtons() + '--------------------------------------------------------------------------------------- + ' Procedure : GetListOfMacrosCalledByButtons + ' Author : @byronwall + ' Date : 2016 01 28 + ' Purpose : prints out a list of macros that are assigned to shapes + '--------------------------------------------------------------------------------------- + ' + + Dim sht As Worksheet + Dim shp As Shape + + For Each sht In Worksheets + For Each shp In sht.Shapes + If shp.OnAction <> "" Then + Debug.Print shp.OnAction + End If + Next + Next +End Sub + +Public Sub CountUnique() + '--------------------------------------------------------------------------------------- + ' Procedure : CountUnique + ' Author : @byronwall + ' Date : 2016 01 27 + ' Purpose : counts the number of unique values in a Range + '--------------------------------------------------------------------------------------- + ' + + Dim rng_data As Range + + Set rng_data = GetInputOrSelection("select the range to count unique") + Set rng_data = Intersect(rng_data, rng_data.Parent.UsedRange) + + Dim dict_vals As New Dictionary + + Dim rng_val As Range + + For Each rng_val In rng_data + If Not dict_vals.Exists(rng_val.Value) Then + dict_vals.Add rng_val.Value, 1 + End If + Next + + MsgBox "items: " & dict_vals.count + +End Sub + +Public Sub Formula_ConcatenateCells() + '--------------------------------------------------------------------------------------- + ' Procedure : Formula_ConcatenateCells + ' Author : @byronwall + ' Date : 2016 01 27 + ' Purpose : will output a formula of concatenations based on cells + '--------------------------------------------------------------------------------------- + ' + + Dim rng_cell As Range + Dim rng_joins As Range + + 'get the cell to output to and the ranges to join + Set rng_cell = GetInputOrSelection("Select the cell to put the formula") + Set rng_joins = Application.InputBox("Select the cells to join", Type:=8) + + 'get the separator + Dim str_delim As String + str_delim = Application.InputBox("What delimeter to use?") + str_delim = "&""" & str_delim & """&" + + Dim arr_addr As Variant + ReDim arr_addr(1 To rng_joins.count) + + Dim int_count As Long + int_count = 1 + + Dim rng_join As Range + For Each rng_join In rng_joins + arr_addr(int_count) = rng_join.Address(False, False) + int_count = int_count + 1 + Next + + Dim str_form As String + str_form = "=" & Join(arr_addr, str_delim) + + rng_cell.Formula = str_form + +End Sub + +Public Sub Formula_ClosestInGroup() + '--------------------------------------------------------------------------------------- + ' Procedure : Formula_ClosestInGroup + ' Author : @byronwall + ' Date : 2016 01 27 + ' Purpose : Adds a formula that puts a given cell into a group of values based on closest value + '--------------------------------------------------------------------------------------- + ' + + Dim rng_check As Range + Dim rng_group As Range + Dim rng_cell As Range + + Set rng_cell = GetInputOrSelection("Select the cell to put the formula") + Set rng_check = Application.InputBox("Select the cell to find the group of", Type:=8) + Set rng_group = Application.InputBox("Select the group the cell belongs to", Type:=8) + + Dim str_form As String + + str_form = "=INDEX(" & rng_group.Address(True, True, xlA1, True) & _ + ",MATCH(MIN(ABS(" & rng_group.Address(True, True, xlA1, True) & "-" & _ + rng_check.Address(False, False) & ")),ABS(" & rng_group.Address(True, True, xlA1, True) & "-" & rng_check.Address(False, False) & "),0))" + + rng_cell.FormulaArray = str_form + +End Sub + +Public Sub SelectAllArrayFormulas() + '--------------------------------------------------------------------------------------- + ' Procedure : SelectAllArrayFormulas + ' Author : @byronwall + ' Date : 2016 01 27 + ' Purpose : selects all cells on current sheet that have an array formula + '--------------------------------------------------------------------------------------- + ' + + Dim rng_forms As Range + + Set rng_forms = ActiveSheet.UsedRange + + Dim rng_select As Range + + Dim rng_form As Range + For Each rng_form In rng_forms + If rng_form.HasArray Then + If rng_select Is Nothing Then + Set rng_select = rng_form + Else + Set rng_select = Union(rng_select, rng_form) + End If + End If + Next + + rng_select.Select + +End Sub + +Public Sub CharacterCodesForSelection() + '--------------------------------------------------------------------------------------- + ' Procedure : CharacterCodesForSelection + ' Author : @byronwall + ' Date : 2016 01 27 + ' Purpose : will output each character in the text + '--------------------------------------------------------------------------------------- + ' + + Dim letter As Variant + + Dim rng_val As Range + Set rng_val = Selection + + Dim i As Long + For i = 1 To Len(rng_val.Value) + MsgBox Asc(Mid(rng_val.Value, i, 1)) + Next + +End Sub + +Public Sub Formula_CreateCountNameForArray() + '--------------------------------------------------------------------------------------- + ' Procedure : Formula_CreateCountNameForArray + ' Author : @byronwall + ' Date : 2016 01 21 + ' Purpose : meant to create formula with limited range of column + '--------------------------------------------------------------------------------------- + ' + + Dim rng_named As Range + + Dim str_name As String + str_name = Application.InputBox("Name of the range", Type:=2) + + Set rng_named = ActiveWorkbook.Names(str_name).RefersToRange + + Dim str_form As String + str_form = "=INDEX(" & str_name & ",1,1):INDEX(" & str_name & ",COUNTA(" & str_name & "),1)" + + ActiveWorkbook.Names.Add str_name & "_limited", str_form + +End Sub + +Public Sub CopyDiscontinuousRangeValuesToClipboard() + + Dim rngCSV As Range + Set rngCSV = GetInputOrSelection("Choose range for converting to CSV") + + If rngCSV Is Nothing Then + Exit Sub + End If + + 'get the counts for rows/columns + Dim int_row As Long + Dim int_cols As Long + + Set rngCSV = Intersect(rngCSV, rngCSV.Parent.UsedRange) + + 'build the string array + Dim arr_rows() As String + ReDim arr_rows(1 To rngCSV.Areas(1).Rows.count) As String + + Dim bool_firstArea As Boolean + bool_firstArea = True + + Dim rng_area As Range + For Each rng_area In rngCSV.Areas + For int_row = 1 To UBound(arr_rows) + If bool_firstArea Then + arr_rows(int_row) = Join(Application.Transpose(Application.Transpose(rng_area.Rows(int_row).Value)), vbTab) + Else + arr_rows(int_row) = arr_rows(int_row) & vbTab & Join(Application.Transpose(Application.Transpose(rng_area.Rows(int_row).Value)), vbTab) + End If + Next + + bool_firstArea = False + Next + + Dim clipboard As MSForms.DataObject + Set clipboard = New MSForms.DataObject + + clipboard.SetText Join(arr_rows, vbCrLf) + clipboard.PutInClipboard + +End Sub + Public Sub ComputeDistanceMatrix() -'get the range of inputs, along with input name - Dim inputRange As Range - Set inputRange = Application.InputBox("Select input data", "Input", Type:=8) + '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 myRange_ID As Range - 'Set myRange_ID = Application.InputBox("Select ID data", "ID", Type:=8) + 'Dim rng_ID As Range + 'Set rng_ID = Application.InputBox("Select ID data", "ID", Type:=8) 'turning off updates makes a huge difference here... could also use array for output Application.ScreenUpdating = False @@ -16,157 +477,157 @@ Public Sub ComputeDistanceMatrix() Application.EnableEvents = False 'create new workbook - Dim myBook As Workbook - Set myBook = Workbooks.Add + Dim wkbk As Workbook + Set wkbk = Workbooks.Add - Dim newSheet As Worksheet - Set newSheet = myBook.Sheets(1) - newSheet.name = "scaled data" + Dim sht_out As Worksheet + Set sht_out = wkbk.Sheets(1) + sht_out.name = "scaled data" 'copy data over to standardize - inputRange.Copy myBook.Sheets(1).Range("A1") + rng_input.Copy wkbk.Sheets(1).Range("A1") 'go to edge of data, add a column, add STANDARDIZE, copy paste values, delete - - Dim dataRange As Range - Set dataRange = newSheet.Range("A1").CurrentRegion - Dim myColumn As Range - For Each myColumn In dataRange.Columns + 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 edgeCell As Range - Set edgeCell = newSheet.Cells(1, newSheet.Columns.count).End(xlToLeft).Offset(, 1) - + 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)) - - edgeCell.Formula = "=IFERROR(STANDARDIZE(" & myColumn.Cells(1, 1).Address(False, False) & ",AVERAGE(" & _ - myColumn.Address & "),STDEV.S(" & myColumn.Address & ")),0)" - + + 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 - edgeCell.Formula = "=IFERROR(" & myColumn.Cells(1, 1).Address(False, False) & "/AVERAGE(" & _ - myColumn.Address & "),1)" - + rng_edge.Formula = "=IFERROR(" & rng_col.Cells(1, 1).Address(False, False) & "/AVERAGE(" & _ + rng_col.Address & "),1)" + 'fill that down - Range(edgeCell, edgeCell.Offset(, -1).End(xlDown).Offset(, 1)).FillDown + Range(rng_edge, rng_edge.Offset(, -1).End(xlDown).Offset(, 1)).FillDown Next - + Application.Calculate - newSheet.UsedRange.Value = newSheet.UsedRange.Value - dataRange.EntireColumn.Delete - - Dim distanceSheet As Worksheet - Set distanceSheet = myBook.Worksheets.Add() - distanceSheet.name = "distances" + 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" - Dim outboundRange As Range - Set outboundRange = distanceSheet.Range("A1") + Dim rng_out As Range + Set rng_out = sht_dist.Range("A1") 'loop through each row with each other row - Dim firstRow As Range - Dim secondRow As Range - - Set inputRange = newSheet.Range("A1").CurrentRegion + Dim rng_row1 As Range + Dim rng_row2 As Range + + Set rng_input = sht_out.Range("A1").CurrentRegion - For Each firstRow In inputRange.Rows - For Each secondRow In inputRange.Rows + For Each rng_row1 In rng_input.Rows + For Each rng_row2 In rng_input.Rows 'loop through each column and compute the distance - Dim squaredDistance As Double - squaredDistance = 0 + Dim dbl_dist_sq As Double + dbl_dist_sq = 0 - Dim currentColumn As Long - For currentColumn = 1 To firstRow.Cells.count - squaredDistance = squaredDistance + (firstRow.Cells(1, currentColumn) - secondRow.Cells(1, currentColumn)) ^ 2 + Dim int_col As Long + 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 'take the sqrt of that value and output - outboundRange.Value = squaredDistance ^ 0.5 + rng_out.Value = dbl_dist_sq ^ 0.5 'get to next column for output - Set outboundRange = outboundRange.Offset(, 1) + Set rng_out = rng_out.Offset(, 1) Next 'drop down a row and go back to left edge - Set outboundRange = outboundRange.Offset(1).End(xlToLeft) + Set rng_out = rng_out.Offset(1).End(xlToLeft) Next Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True - - distanceSheet.UsedRange.NumberFormat = "0.00" - distanceSheet.UsedRange.EntireColumn.AutoFit - + + sht_dist.UsedRange.NumberFormat = "0.00" + sht_dist.UsedRange.EntireColumn.AutoFit + 'do the coloring - Formatting_AddCondFormat distanceSheet.UsedRange + Formatting_AddCondFormat sht_dist.UsedRange End Sub Sub RemoveAllLegends() - Dim myChartObject As ChartObject + Dim chtObj As ChartObject - For Each myChartObject In Chart_GetObjectsFromObject(Selection) - myChartObject.Chart.HasLegend = False - myChartObject.Chart.HasTitle = True + For Each chtObj In Chart_GetObjectsFromObject(Selection) + chtObj.Chart.HasLegend = False + chtObj.Chart.HasTitle = True - myChartObject.Chart.SeriesCollection(1).MarkerSize = 4 + chtObj.Chart.SeriesCollection(1).MarkerSize = 4 Next End Sub Sub ApplyFormattingToEachColumn() - Dim myRange As Range - For Each myRange In Selection.Columns - - Formatting_AddCondFormat myRange - Next -End Sub - -Private Sub Formatting_AddCondFormat(ByVal myRange As Range) - - myRange.FormatConditions.AddColorScale ColorScaleType:=3 - myRange.FormatConditions(myRange.FormatConditions.count).SetFirstPriority - myRange.FormatConditions(1).ColorScaleCriteria(1).Type = _ - xlConditionValueLowestValue - With myRange.FormatConditions(1).ColorScaleCriteria(1).FormatColor - .Color = 7039480 - .TintAndShade = 0 - End With - myRange.FormatConditions(1).ColorScaleCriteria(2).Type = _ - xlConditionValuePercentile - myRange.FormatConditions(1).ColorScaleCriteria(2).Value = 50 - With myRange.FormatConditions(1).ColorScaleCriteria(2).FormatColor - .Color = 8711167 - .TintAndShade = 0 - End With - myRange.FormatConditions(1).ColorScaleCriteria(3).Type = _ - xlConditionValueHighestValue - With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor - .Color = 8109667 - .TintAndShade = 0 - End With -End Sub - - - -'--------------------------------------------------------------------------------------- -' 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 Selection.Columns + + Formatting_AddCondFormat rng + Next +End Sub - Dim myRange As Range +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 + + + + +Sub TraceDependentsForAll() + '--------------------------------------------------------------------------------------- + ' Procedure : TraceDependentsForAll + ' Author : @byronwall + ' Date : 2015 11 09 + ' Purpose : Quick Sub to iterate through Selection and Trace Dependents for all + '--------------------------------------------------------------------------------------- + ' + Dim rng As Range - For Each myRange In Intersect(Selection, Selection.Parent.UsedRange) - myRange.ShowDependents - Next myRange + For Each rng In Intersect(Selection, Selection.Parent.UsedRange) + rng.ShowDependents + Next rng End Sub diff --git a/src/code/UDFs.bas b/src/code/UDFs.bas index 043c2f3..f7b6f62 100644 --- a/src/code/UDFs.bas +++ b/src/code/UDFs.bas @@ -1,29 +1,22 @@ Attribute VB_Name = "UDFs" -'--------------------------------------------------------------------------------------- -' Module : UDFs -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains all code that is intended to be used as a UDF -'--------------------------------------------------------------------------------------- - Option Explicit -'--------------------------------------------------------------------------------------- -' Procedure : RandLetters -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : UDF that generates a sequence of random letters -'--------------------------------------------------------------------------------------- -' -Public Function RandLetters(numberOfLetters As Long) As String - Dim i As Long +Public Function RandLetters(letterCount As Long) As String + '--------------------------------------------------------------------------------------- + ' Procedure : RandLetters + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : UDF that generates a sequence of random letters + '--------------------------------------------------------------------------------------- + ' + Dim letterIndex As Long Dim letters() As String - ReDim letters(1 To numberOfLetters) + ReDim letters(1 To letterCount) - For i = 1 To numberOfLetters - letters(i) = Chr(Int(Rnd() * 26 + 65)) + For letterIndex = 1 To letterCount + letters(letterIndex) = Chr(Int(Rnd() * 26 + 65)) Next RandLetters = Join(letters(), "") diff --git a/src/code/Updater.bas b/src/code/Updater.bas new file mode 100644 index 0000000..c1d4134 --- /dev/null +++ b/src/code/Updater.bas @@ -0,0 +1,117 @@ +Attribute VB_Name = "Updater" +Option Explicit + +Public Sub CheckForUpdates() + + 'get the path of the current file + Dim strReleaseUrl As String + strReleaseUrl = "https://api.github.com/repos/byronwall/butl/releases" + + Dim strGitHubData As String + strGitHubData = DownloadFileAsString(strReleaseUrl) + + 'this will grab the first file from the most recent release + 'this is a cheap way to "parse" the JSON without a library + Dim strUrl As String + strUrl = Split(Split(strGitHubData, "tag_name"":")(1), """")(1) + + Dim strVersion As String + strVersion = "Current version on GitHub is " & vbCrLf & _ + vbTab & strUrl & vbCrLf & _ + "Version of bUTL on computer is" & vbCrLf & _ + vbTab & bUTL_GetVersion() & vbCrLf & _ + "Do you want to update?" + + Dim shouldUpdate As VbMsgBoxResult + shouldUpdate = MsgBox(strVersion, vbYesNo, "Update?") + + If shouldUpdate = vbYes Then + UpdateSelf + End If + +End Sub + +Public Sub UpdateSelf() + '--------------------------------------------------------------------------------------- + ' Procedure : UpdateSelf + ' Author : @byronwall + ' Date : 2016 02 05 + ' Purpose : will download most recent version and replace current version of self with it + '--------------------------------------------------------------------------------------- + ' + + Dim promptResults As VbMsgBoxResult + promptResults = MsgBox("This will: download the latest bUTL file, close Excel, " & _ + "create a VB script file to copy that file over the current one, and reopen Excel." & vbCrLf & vbCrLf & _ + "Continue?", _ + vbYesNo, "Update bUTL?") + + If promptResults = vbNo Then + Exit Sub + End If + + 'get the path of the current file + Dim strReleaseUrl As String + strReleaseUrl = "https://api.github.com/repos/byronwall/butl/releases" + + Dim strGitHubData As String + strGitHubData = DownloadFileAsString(strReleaseUrl) + + 'this will grab the first file from the most recent release + 'this is a cheap way to "parse" the JSON without a library + Dim strUrl As String + strUrl = Split(Split(strGitHubData, "browser_download_url"":")(1), """")(1) + + Debug.Print strUrl + + Dim str_download_path As String + str_download_path = ThisWorkbook.path & "\" & "butl-github.xlam" + + Download_File strUrl, str_download_path + + Dim fso As FileSystemObject + Dim ts As TextStream + Dim Script As String, ScriptFile As String + Dim A As AddIn + Dim objShell + + + ''actions to be done by the updater: + + 'delete current file + 'rename downloaded file + 'message box that things are done + 'open excel back up + 'delete script + + Script = _ + "'sleep so Excel closes" & vbCrLf & _ + "Wscript.Sleep 1000" & vbCrLf & _ + "Set fso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _ + "fso.DeleteFile ""[butl-current]""" & vbCrLf & _ + "fso.MoveFile ""[butl-new]"", ""[butl-current]""" & vbCrLf & _ + "Set objShell = CreateObject(""Wscript.Shell"")" & vbCrLf & _ + "objShell.Run ""excel.exe""" & vbCrLf & _ + "fso.DeleteFile Wscript.ScriptFullName" & vbCrLf & _ + "MsgBox ""bUTL is now updated to the current version""" + + Script = Replace(Script, "[butl-current]", ThisWorkbook.path & "\" & ThisWorkbook.name) + Script = Replace(Script, "[butl-new]", str_download_path) + + + Set fso = CreateObject("Scripting.FileSystemObject") + + ScriptFile = ThisWorkbook.path & "\" & "butl updater.vbs" + Set ts = fso.CreateTextFile(ScriptFile) + ts.Write Script + ts.Close + + Dim str_scriptPath As String + str_scriptPath = """" & ScriptFile & """" + + CreateObject("Wscript.Shell").Run str_scriptPath + + Application.DisplayAlerts = False + Application.Quit +End Sub + diff --git a/src/code/Usability.bas b/src/code/Usability.bas index 330e6cc..86b01ae 100644 --- a/src/code/Usability.bas +++ b/src/code/Usability.bas @@ -1,315 +1,236 @@ Attribute VB_Name = "Usability" Option Explicit -'--------------------------------------------------------------------------------------- -' Module : Usability -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Contains an assortment of code that automates some task -'--------------------------------------------------------------------------------------- - - -Sub CreatePdfOfEachXlsxFileInFolder() - - 'pick a folder - Dim pickedFolder As FileDialog - Set pickedFolder = Application.FileDialog(msoFileDialogFolderPicker) - - pickedFolder.Show - - Dim path As String - path = pickedFolder.SelectedItems(1) & "\" - - 'find all files in the folder - Dim fileName As String - fileName = Dir(path & "*.xlsx") - - Do While fileName <> "" - - Dim myBook As Workbook - Set myBook = Workbooks.Open(path & fileName, , True) - - Dim mySheet As Worksheet - - For Each mySheet In myBook.Worksheets - mySheet.Range("A16").EntireRow.RowHeight = 15.75 - mySheet.Range("A17").EntireRow.RowHeight = 15.75 - mySheet.Range("A22").EntireRow.RowHeight = 15.75 - mySheet.Range("A23").EntireRow.RowHeight = 15.75 - Next - - myBook.ExportAsFixedFormat xlTypePDF, path & fileName & ".pdf" - myBook.Close False - - fileName = Dir - Loop -End Sub - -Sub MakeSeveralBoxesWithNumbers() - - Dim myShape As Shape - Dim mySheet As Worksheet - - Dim selectedRange As Range - Set selectedRange = Application.InputBox("select range", Type:=8) - - Set mySheet = ActiveSheet - - Dim counter As Long - - For counter = 1 To InputBox("How many?") - - Set myShape = mySheet.Shapes.AddTextbox(msoShapeRectangle, selectedRange.left, _ - selectedRange.top + 20 * counter, 20, 20) - - myShape.title = counter - - myShape.Fill.Visible = msoFalse - myShape.Line.Visible = msoFalse - - myShape.TextFrame2.TextRange.Characters.Text = counter - - With myShape.TextFrame2.TextRange.Font.Fill - .Visible = msoTrue - .ForeColor.RGB = RGB(0, 0, 0) - .Transparency = 0 - .Solid - End With - - Next - -End Sub - -'--------------------------------------------------------------------------------------- -' Procedure : ColorInputs -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Finds cells with no value and colors them based on having a formula? -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' Sub ColorInputs() - - Dim myRange As Range + '--------------------------------------------------------------------------------------- + ' Procedure : ColorInputs + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Finds cells with no value and colors them based on having a formula? + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + Dim c As Range 'This is finding cells that aren't blank, but the description says it should be cells with no values.. - For Each myRange In Selection - If myRange.Value <> "" Then - If myRange.HasFormula Then - myRange.Interior.ThemeColor = msoThemeColorAccent1 + For Each c In Selection + If c.Value <> "" Then + If c.HasFormula Then + c.Interior.ThemeColor = msoThemeColorAccent1 Else - myRange.Interior.ThemeColor = msoThemeColorAccent2 + c.Interior.ThemeColor = msoThemeColorAccent2 End If End If - Next myRange + Next c End Sub -'--------------------------------------------------------------------------------------- -' Procedure : CombineAllSheetsData -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Combines all sheets, resuing columns where the same -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub CombineAllSheetsData() - -'create the new wkbk and sheet - Dim combinedBook As Workbook - Dim dataBook As Workbook - Set dataBook = ActiveWorkbook - Set combinedBook = Workbooks.Add +Sub CombineAllSheetsData() + '--------------------------------------------------------------------------------------- + ' Procedure : CombineAllSheetsData + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Combines all sheets, resuing columns where the same + ' Flag : not-used + '--------------------------------------------------------------------------------------- + ' + 'create the new wkbk and sheet + Dim wbCombo As Workbook + Dim wbData As Workbook + + Set wbData = ActiveWorkbook + Set wbCombo = Workbooks.Add Dim wsCombined As Worksheet - Set wsCombined = combinedBook.Sheets.Add + Set wsCombined = wbCombo.Sheets.Add - Dim first As Boolean - first = True + Dim boolFirst As Boolean + boolFirst = True - Dim combinedRow As Long - combinedRow = 1 + Dim iComboRow As Long + iComboRow = 1 - Dim dataSheet As Worksheet - For Each dataSheet In dataBook.Sheets - If dataSheet.name <> wsCombined.name Then + Dim wsData As Worksheet + For Each wsData In wbData.Sheets + If wsData.name <> wsCombined.name Then - dataSheet.Unprotect + wsData.Unprotect 'get the headers squared up - If first Then + If boolFirst Then 'copy over all headers - dataSheet.Rows(1).Copy wsCombined.Range("A1") + wsData.Rows(1).Copy wsCombined.Range("A1") - first = False + boolFirst = False Else 'search for missing columns - Dim headerRange As Range - For Each headerRange In Intersect(dataSheet.Rows(1), dataSheet.UsedRange) + Dim rngHeader As Range + For Each rngHeader In Intersect(wsData.Rows(1), wsData.UsedRange) 'check if it exists Dim varHdrMatch As Variant - varHdrMatch = Application.Match(headerRange, wsCombined.Rows(1), 0) + varHdrMatch = Application.Match(rngHeader, wsCombined.Rows(1), 0) 'if not, add to header row If IsError(varHdrMatch) Then - wsCombined.Range("A1").End(xlToRight).Offset(, 1) = headerRange + wsCombined.Range("A1").End(xlToRight).Offset(, 1) = rngHeader End If - Next headerRange + Next rngHeader End If 'find the PnPID column for combo - Dim columnID As Long - columnID = Application.Match("PnPID", wsCombined.Rows(1), 0) + Dim int_colId As Long + int_colId = Application.Match("PnPID", wsCombined.Rows(1), 0) 'find the PnPID column for data - Dim dateColumn As Long - dateColumn = Application.Match("PnPID", dataSheet.Rows(1), 0) + Dim iColIDData As Long + iColIDData = Application.Match("PnPID", wsData.Rows(1), 0) 'add the data, row by row - Dim myRange As Range - For Each myRange In dataSheet.UsedRange.SpecialCells(xlCellTypeConstants) - If myRange.row > 1 Then + Dim c As Range + For Each c In wsData.UsedRange.SpecialCells(xlCellTypeConstants) + If c.Row > 1 Then 'check if the PnPID exists in the combo sheet - Dim dataRow As Variant - dataRow = Application.Match( _ - dataSheet.Cells(myRange.row, dateColumn), _ - wsCombined.Columns(columnID), _ + Dim iDataRow As Variant + iDataRow = Application.Match( _ + wsData.Cells(c.Row, iColIDData), _ + wsCombined.Columns(int_colId), _ 0) 'add new row if it did not exist and id number - If IsError(dataRow) Then - dataRow = wsCombined.Columns(columnID).Cells(wsCombined.Rows.count, 1).End(xlUp).Offset(1).row - wsCombined.Cells(dataRow, columnID) = dataSheet.Cells(myRange.row, dateColumn) + If IsError(iDataRow) Then + iDataRow = wsCombined.Columns(int_colId).Cells(wsCombined.Rows.count, 1).End(xlUp).Offset(1).Row + wsCombined.Cells(iDataRow, int_colId) = wsData.Cells(c.Row, iColIDData) End If 'get column - Dim myColumn As Long - myColumn = Application.Match(dataSheet.Cells(1, myRange.Column), wsCombined.Rows(1), 0) + Dim iCol As Long + iCol = Application.Match(wsData.Cells(1, c.Column), wsCombined.Rows(1), 0) 'update combo data - wsCombined.Cells(dataRow, myColumn) = myRange + wsCombined.Cells(iDataRow, iCol) = c End If - Next myRange + Next c End If - Next dataSheet + Next wsData End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ConvertSelectionToCsv -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Crude CSV output from the current selection, works with numbers -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub ConvertSelectionToCsv() - - Dim rangeForCSV As Range - Set rangeForCSV = GetInputOrSelection("Choose range for converting to CSV") - If rangeForCSV Is Nothing Then +Sub ConvertSelectionToCsv() + '--------------------------------------------------------------------------------------- + ' Procedure : ConvertSelectionToCsv + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Crude CSV output from the current selection, works with numbers + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + Dim rngCSV As Range + Set rngCSV = GetInputOrSelection("Choose range for converting to CSV") + + If rngCSV Is Nothing Then Exit Sub End If - Dim outboundCSV As String - outboundCSV = "" + Dim csvOut As String + csvOut = "" Dim csvRow As Range - For Each csvRow In rangeForCSV.Rows + For Each csvRow In rngCSV.Rows - Dim myArray As Variant - myArray = Application.Transpose(Application.Transpose(csvRow.Rows.Value2)) + Dim arr As Variant + arr = Application.Transpose(Application.Transpose(csvRow.Rows.Value2)) 'TODO: improve this to use another Join instead of string concats - outboundCSV = outboundCSV & Join(myArray, ",") & vbCrLf + csvOut = csvOut & Join(arr, ",") & vbCrLf Next csvRow - Dim clipBoard As MSForms.DataObject - Set clipBoard = New MSForms.DataObject + Dim clipboard As MSForms.DataObject + Set clipboard = New MSForms.DataObject - clipBoard.SetText outboundCSV - clipBoard.PutInClipboard + clipboard.SetText csvOut + clipboard.PutInClipboard 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 selectedRange As Range - Set selectedRange = Selection - - clipBoard.SetText selectedRange.Address(True, True, xlA1, True) - clipBoard.PutInClipboard + '--------------------------------------------------------------------------------------- + ' 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 -' Date : 2015 07 24 -' Purpose : Copies the cells and clears the source Range -'--------------------------------------------------------------------------------------- -' 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) + Dim shouldDeleteHiddenRows As VbMsgBoxResult + shouldDeleteHiddenRows = MsgBox("This will permanently delete hidden rows. They cannot be recovered. Are you sure?", vbYesNo) - If Not x = vbYes Then + If Not shouldDeleteHiddenRows = vbYes Then Exit Sub End If Application.ScreenUpdating = False - 'We might as well tell the user how many rows were hidden - Dim counter As Long - counter = 0 + 'collect a range to delete at end, using UNION-DELETE + Dim rngToDelete As Range + + Dim iCount As Long + iCount = 0 With ActiveSheet - Dim i As Long - For i = .UsedRange.Rows.count To 1 Step -1 - If .Rows(i).Hidden Then - .Rows(i).Delete - counter = counter + 1 + Dim rowIndex As Long + For rowIndex = .UsedRange.Rows.count To 1 Step -1 + If .Rows(rowIndex).Hidden Then + If rngToDelete Is Nothing Then + Set rngToDelete = .Rows(rowIndex) + Else + Set rngToDelete = Union(rngToDelete, .Rows(rowIndex)) + End If + iCount = iCount + 1 End If - Next i + Next rowIndex End With + + rngToDelete.Delete + Application.ScreenUpdating = True - MsgBox (counter & " rows were deleted") + MsgBox (iCount & " rows were deleted") End Sub -'--------------------------------------------------------------------------------------- -' Procedure : CutPasteTranspose -' Author : @byronwall, @RaymondWise -' Date : 2015 07 31 -' Purpose : Does a cut/transpose by cutting each cell individually -'--------------------------------------------------------------------------------------- -' -'########Still Needs to address Issue#23############# Sub CutPasteTranspose() - + '--------------------------------------------------------------------------------------- + ' Procedure : CutPasteTranspose + ' Author : @byronwall, @RaymondWise + ' Date : 2015 07 31 + ' Purpose : Does a cut/transpose by cutting each cell individually + '--------------------------------------------------------------------------------------- + ' + + '########Still Needs to address Issue#23############# On Error GoTo errHandler - Dim rangeToSelect As Range + Dim rngSelect As Range 'TODO #Should use new inputbox function - Set rangeToSelect = Selection + Set rngSelect = Selection - Dim outboundRange As Range - Set outboundRange = Application.InputBox("Select output corner", Type:=8) + Dim rngOut As Range + Set rngOut = Application.InputBox("Select output corner", Type:=8) Application.ScreenUpdating = False Application.EnableEvents = False @@ -317,35 +238,35 @@ Sub CutPasteTranspose() - Dim myCorner As Range - Set myCorner = rangeToSelect.Cells(1, 1) + Dim rCorner As Range + Set rCorner = rngSelect.Cells(1, 1) - Dim myRow As Long - myRow = myCorner.row - Dim incomingColumn As Long - incomingColumn = myCorner.Column + Dim iCRow As Long + iCRow = rCorner.Row + Dim iCCol As Long + iCCol = rCorner.Column - Dim outboundRow As Long - Dim outboundColumn As Long - outboundRow = outboundRange.row - outboundColumn = outboundRange.Column + Dim iORow As Long + Dim iOCol As Long + iORow = rngOut.Row + iOCol = rngOut.Column - outboundRange.Activate + rngOut.Activate 'Check to not overwrite - Dim myRange As Range - For Each myRange In rangeToSelect - If Not Intersect(rangeToSelect, Cells(outboundRow + myRange.Column - incomingColumn, outboundColumn + myRange.row - myRow)) Is Nothing Then + 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") Exit Sub End If Next - For Each myRange In rangeToSelect - myRange.Cut - ActiveSheet.Cells(outboundRow + myRange.Column - incomingColumn, outboundColumn + myRange.row - myRow).Activate + For Each c In rngSelect + c.Cut + ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).Activate ActiveSheet.Paste - Next myRange + Next c Application.CutCopyMode = False @@ -356,165 +277,59 @@ Sub CutPasteTranspose() errHandler: End Sub -'--------------------------------------------------------------------------------------- -' Procedure : EvaluateArrayFormulaOnNewSheet -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Wacky thing to force an Array formula to return as an Array -' Flag : not-used -'--------------------------------------------------------------------------------------- -' -Sub EvaluateArrayFormulaOnNewSheet() - -'cut cell with formula - Dim streetAddress As String - Dim startingRange As Range - Set startingRange = Sheet1.Range("J2") - streetAddress = startingRange.Address - - startingRange.Cut - - 'create new sheet - Dim mySheet As Worksheet - Set mySheet = Worksheets.Add - - 'paste cell onto sheet - Dim myArrayRange As Range - Set myArrayRange = mySheet.Range("A1") - mySheet.Paste myArrayRange - - 'expand Array formula size.. resize to whatever size is needed - myArrayRange.Resize(3).FormulaArray = myArrayRange.FormulaArray - - 'get your result - Dim myArray As Variant - myArray = Application.Evaluate(myArrayRange.CurrentArray.Address) - - ''''do something with your result here... it is an Array - - - 'shrink the formula back to one cell - Dim myFormula As String - myFormula = myArrayRange.FormulaArray - - myArrayRange.CurrentArray.ClearContents - myArrayRange.FormulaArray = myFormula - - 'cut and paste back to original spot - myArrayRange.Cut - - Sheet1.Paste Sheet1.Range(streetAddress) - - Application.DisplayAlerts = False - mySheet.Delete - Application.DisplayAlerts = True - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : ExportFilesFromFolder -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Goes through a folder and process all workbooks therein -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub ExportFilesFromFolder() - '###Needs error handling - 'TODO: consider deleting this Sub since it is quite specific - Application.ScreenUpdating = False - - Dim file As Variant - Dim path As String - path = InputBox("What path?") - - file = Dir(path) - While (file <> "") - - Debug.Print path & file - - Dim fileName As String - - fileName = path & file - - Dim wbActive As Workbook - Set wbActive = Workbooks.Open(fileName) - - Dim wsActive As Worksheet - Set wsActive = wbActive.Sheets("Case Summary") - - With ActiveSheet.PageSetup - .TopMargin = Application.InchesToPoints(0.4) - .BottomMargin = Application.InchesToPoints(0.4) - End With - - wsActive.ExportAsFixedFormat xlTypePDF, path & "PDFs\" & file & ".pdf" - - wbActive.Close False - - file = Dir - Wend - - Application.ScreenUpdating = True - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : FillValueDown -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Does a fill of blank values from the cell above with a value -'--------------------------------------------------------------------------------------- -' Sub FillValueDown() - - Dim inputRange As Range - Set inputRange = GetInputOrSelection("Select range for waterfall") - - If inputRange Is Nothing Then + '--------------------------------------------------------------------------------------- + ' Procedure : FillValueDown + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Does a fill of blank values from the cell above with a value + '--------------------------------------------------------------------------------------- + ' + Dim rngInput As Range + Set rngInput = GetInputOrSelection("Select range for waterfall") + + If rngInput Is Nothing Then Exit Sub End If - Dim myRange As Range - For Each myRange In Intersect(inputRange.SpecialCells(xlCellTypeBlanks), inputRange.Parent.UsedRange) - myRange = myRange.End(xlUp) - Next myRange + Dim c As Range + For Each c In Intersect(rngInput.SpecialCells(xlCellTypeBlanks), rngInput.Parent.UsedRange) + c = c.End(xlUp) + Next c End Sub -'--------------------------------------------------------------------------------------- -' Procedure : ForceRecalc -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Provides a button to do a full recalc -'--------------------------------------------------------------------------------------- -' -Sub ForceRecalc() +Sub ForceRecalc() + '--------------------------------------------------------------------------------------- + ' Procedure : ForceRecalc + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Provides a button to do a full recalc + '--------------------------------------------------------------------------------------- + ' Application.CalculateFullRebuild End Sub -'--------------------------------------------------------------------------------------- -' Procedure : GenerateRandomData -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Generates a block of random data for testing questions on SO -'--------------------------------------------------------------------------------------- -' -Sub GenerateRandomData() - Dim myRange As Range - Set myRange = Range("B2") +Sub GenerateRandomData() + '--------------------------------------------------------------------------------------- + ' Procedure : GenerateRandomData + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Generates a block of random data for testing questions on SO + '--------------------------------------------------------------------------------------- + ' + Dim c As Range + Set c = Range("B2") Dim i As Long For i = 0 To 3 - myRange.Offset(, i) = Chr(65 + i) + c.Offset(, i) = Chr(65 + i) - With myRange.Offset(1, i).Resize(10) + With c.Offset(1, i).Resize(10) Select Case i Case 0 .Formula = "=TODAY()+ROW()" @@ -530,15 +345,15 @@ Sub GenerateRandomData() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : OpenContainingFolder -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Open the folder that contains the ActiveWorkbook -'--------------------------------------------------------------------------------------- -' -Sub OpenContainingFolder() +Sub OpenContainingFolder() + '--------------------------------------------------------------------------------------- + ' Procedure : OpenContainingFolder + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Open the folder that contains the ActiveWorkbook + '--------------------------------------------------------------------------------------- + ' Dim wb As Workbook Set wb = ActiveWorkbook @@ -550,95 +365,93 @@ Sub OpenContainingFolder() End Sub -'--------------------------------------------------------------------------------------- -' Procedure : PivotSetAllFields -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Sets all fields in a PivotTable to use a certain calculation type -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' -Sub PivotSetAllFields() - - Dim myPivotTable As PivotTable - Dim mySheet As Worksheet - Set mySheet = ActiveSheet +Sub PivotSetAllFields() + '--------------------------------------------------------------------------------------- + ' Procedure : PivotSetAllFields + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Sets all fields in a PivotTable to use a certain calculation type + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' + Dim pTable As PivotTable + Dim ws As Worksheet + + Set ws = ActiveSheet MsgBox "This defaults to the average for every Pivot table on the sheet. Edit code for other result." - For Each myPivotTable In mySheet.PivotTables - Dim myPivotField As PivotField - For Each myPivotField In myPivotTable.DataFields + For Each pTable In ws.PivotTables + Dim pField As PivotField + For Each pField In pTable.DataFields On Error Resume Next - myPivotField.Function = xlAverage - Next myPivotField - Next myPivotTable + pField.Function = xlAverage + Next pField + Next pTable End Sub - -'--------------------------------------------------------------------------------------- -' Procedure : SeriesSplit -' Author : @byronwall -' Date : 2015 08 11 -' Purpose : Takes a category columns and splits the values out into new columns for each unique entry -'--------------------------------------------------------------------------------------- -' Sub SeriesSplit() - + '--------------------------------------------------------------------------------------- + ' Procedure : SeriesSplit + ' Author : @byronwall + ' Date : 2015 08 11 + ' Purpose : Takes a category columns and splits the values out into new columns for each unique entry + '--------------------------------------------------------------------------------------- + ' On Error GoTo ErrorNoSelection - Dim rangeToSelection As Range - Set rangeToSelection = Application.InputBox("Select category range with heading", Type:=8) - Set rangeToSelection = Intersect(rangeToSelection, rangeToSelection.Parent.UsedRange).SpecialCells(xlCellTypeVisible, xlLogical + xlNumbers + xlTextValues) + 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 valueRange As Range - Set valueRange = Application.InputBox("Select values range with heading", Type:=8) - Set valueRange = Intersect(valueRange, valueRange.Parent.UsedRange) + Dim rngValues As Range + Set rngValues = Application.InputBox("Select values range with heading", Type:=8) + Set rngValues = Intersect(rngValues, rngValues.Parent.UsedRange) On Error GoTo 0 'determine default value - Dim defaultValue As Variant - defaultValue = InputBox("Enter the default value", , "#N/A") + Dim strDefault As Variant + strDefault = InputBox("Enter the default value", , "#N/A") 'detect cancel and exit - If StrPtr(defaultValue) = 0 Then + If StrPtr(strDefault) = 0 Then Exit Sub End If Dim dictCategories As New Dictionary - Dim myCategory As Range - For Each myCategory In rangeToSelection + Dim rngCategory As Range + For Each rngCategory In rngSelection 'skip the header row - If myCategory.Address <> rangeToSelection.Cells(1).Address Then - dictCategories(myCategory.Value) = 1 + If rngCategory.Address <> rngSelection.Cells(1).Address Then + dictCategories(rngCategory.Value) = 1 End If - Next myCategory + Next rngCategory - valueRange.EntireColumn.Offset(, 1).Resize(, dictCategories.count).Insert + rngValues.EntireColumn.Offset(, 1).Resize(, dictCategories.count).Insert 'head the columns with the values - Dim myValues As Variant - Dim counter As Long - counter = 1 - For Each myValues In dictCategories - valueRange.Cells(1).Offset(, counter) = myValues - counter = counter + 1 - Next myValues + Dim varValues As Variant + Dim iCount As Long + iCount = 1 + For Each varValues In dictCategories + rngValues.Cells(1).Offset(, iCount) = varValues + iCount = iCount + 1 + Next varValues 'put the formula in for each column '=IF(RC13=R1C,RC16,#N/A) - Dim myFormula As Variant - myFormula = "=IF(RC" & rangeToSelection.Column & " =R" & _ - valueRange.Cells(1).row & "C,RC" & valueRange.Column & "," & defaultValue & ")" + Dim strFormula As Variant + strFormula = "=IF(RC" & rngSelection.Column & " =R" & _ + rngValues.Cells(1).Row & "C,RC" & rngValues.Column & "," & strDefault & ")" Dim rngFormula As Range - Set rngFormula = valueRange.Offset(1, 1).Resize(valueRange.Rows.count - 1, dictCategories.count) - rngFormula.FormulaR1C1 = myFormula + Set rngFormula = rngValues.Offset(1, 1).Resize(rngValues.Rows.count - 1, dictCategories.count) + rngFormula.FormulaR1C1 = strFormula rngFormula.EntireColumn.AutoFit Exit Sub @@ -649,67 +462,69 @@ 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() +Sub SeriesSplitIntoBins() + '--------------------------------------------------------------------------------------- + ' Procedure : SeriesSplitIntoBins + ' Author : @byronwall + ' Date : 2015 11 03 + ' Purpose : Code will break a column of continuous data into bins for plotting + '--------------------------------------------------------------------------------------- + ' On Error GoTo ErrorNoSelection - Dim rangeToSelection As Range - Set rangeToSelection = Application.InputBox("Select category range with heading", _ + Dim rngSelection As Range + Set rngSelection = Application.InputBox("Select category range with heading", _ Type:=8) - Set rangeToSelection = Intersect(rangeToSelection, _ - rangeToSelection.Parent.UsedRange).SpecialCells(xlCellTypeVisible, xlLogical + _ - xlNumbers + xlTextValues) + Set rngSelection = Intersect(rngSelection, _ + rngSelection.Parent.UsedRange).SpecialCells(xlCellTypeVisible, xlLogical + _ + xlNumbers + xlTextValues) - Dim valueRange As Range - Set valueRange = Application.InputBox("Select values range with heading", _ + Dim rngValues As Range + Set rngValues = Application.InputBox("Select values range with heading", _ Type:=8) - Set valueRange = Intersect(valueRange, valueRange.Parent.UsedRange) + Set rngValues = Intersect(rngValues, rngValues.Parent.UsedRange) ''need to prompt for max/min/bins - Dim maximumValue As Double, minimumValue As Double, myBins As Long - - minimumValue = Application.InputBox("Minimum value.", "Min", _ - WorksheetFunction.Min(rangeToSelection), Type:=1) - maximumValue = Application.InputBox("Maximum value.", "Max", _ - WorksheetFunction.Max(rangeToSelection), Type:=1) - myBins = Application.InputBox("Number of groups.", "Bins", _ - WorksheetFunction.RoundDown(Math.Sqr(WorksheetFunction.count(rangeToSelection)), _ + Dim dbl_max As Double, dbl_min As Double, int_bins As Long + + 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 defaultValue As Variant - defaultValue = Application.InputBox("Enter the default value", "Default", _ + Dim strDefault As Variant + strDefault = Application.InputBox("Enter the default value", "Default", _ "#N/A") 'detect cancel and exit - If StrPtr(defaultValue) = 0 Then + If StrPtr(strDefault) = 0 Then Exit Sub End If ''TODO prompt for output location - valueRange.EntireColumn.Offset(, 1).Resize(, myBins + 2).Insert + 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 binNumber As Long - For binNumber = 0 To myBins - valueRange.Cells(1).Offset(, binNumber + 1) = minimumValue + (maximumValue - _ - minimumValue) * binNumber / myBins + Dim int_binNo As Long + 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 - valueRange.Cells(1).Offset(, myBins + 2).FormulaR1C1 = "=RC[-1]" + rngValues.Cells(1).Offset(, int_bins + 2).FormulaR1C1 = "=RC[-1]" 'FIRST =IF($D2 <=V$1,$U2,#N/A) '=IF(RC4 <=R1C,RC21,#N/A) @@ -724,38 +539,38 @@ Sub SeriesSplitIntoBins() 'put the formula in for each column '=IF(RC13=R1C,RC16,#N/A) - Dim myFormula As Variant - myFormula = "=IF(AND(RC" & rangeToSelection.Column & " <=R" & _ - valueRange.Cells(1).row & "C," & "RC" & rangeToSelection.Column & ">R" & _ - valueRange.Cells(1).row & "C[-1]" & ")" & ",RC" & valueRange.Column & "," & _ - defaultValue & ")" - - Dim firstFormula As Variant - firstFormula = "=IF(AND(RC" & rangeToSelection.Column & " <=R" & _ - valueRange.Cells(1).row & "C)" & ",RC" & valueRange.Column & "," & defaultValue _ + 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 lastFormula As Variant - lastFormula = "=IF(AND(RC" & rangeToSelection.Column & " >R" & _ - valueRange.Cells(1).row & "C)" & ",RC" & valueRange.Column & "," & defaultValue _ + 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 = valueRange.Offset(1, 1).Resize(valueRange.Rows.count - 1, _ - myBins + 2) - rngFormula.FormulaR1C1 = myFormula + 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 = firstFormula - rngFormula.Columns(rngFormula.Columns.count).FormulaR1C1 = lastFormula + 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, myBins + 1).NumberFormat = _ - "<= General" - rngFormula.Offset(-1).Rows(1).Offset(, myBins + 1).NumberFormat = _ - "> General" + 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 @@ -766,61 +581,31 @@ ErrorNoSelection: End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : mySheet_DeleteHiddenRows -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Deletes the hidden rows in a sheet. Good for a "permanent" filter -'--------------------------------------------------------------------------------------- -' -'Changed sub name to avoid reserved object name -Sub mySheet_DeleteHiddenRows() - - Application.ScreenUpdating = False - Dim row As Range - Dim i As Long - For i = ActiveSheet.UsedRange.Rows.count To 1 Step -1 - - - Set row = ActiveSheet.Rows(i) - - If row.Hidden Then - row.Delete - End If - Next i - - Application.ScreenUpdating = True - -End Sub - -'--------------------------------------------------------------------------------------- -' Procedure : UnhideAllRowsAndColumns -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Unhides everything in a Worksheet -' Flag : new-feature -'--------------------------------------------------------------------------------------- -' Sub UnhideAllRowsAndColumns() - + '--------------------------------------------------------------------------------------- + ' Procedure : UnhideAllRowsAndColumns + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Unhides everything in a Worksheet + ' Flag : new-feature + '--------------------------------------------------------------------------------------- + ' ActiveSheet.Cells.EntireRow.Hidden = False ActiveSheet.Cells.EntireColumn.Hidden = False End Sub -'--------------------------------------------------------------------------------------- -' Procedure : UpdateScrollbars -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Cheap trick that forces Excel to update the scroll bars after a large deletion -'--------------------------------------------------------------------------------------- -' -Sub UpdateScrollbars() - Dim myRange As Variant - myRange = ActiveSheet.UsedRange.Address +Sub UpdateScrollbars() + '--------------------------------------------------------------------------------------- + ' Procedure : UpdateScrollbars + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Cheap trick that forces Excel to update the scroll bars after a large deletion + '--------------------------------------------------------------------------------------- + ' + Dim rng As Variant + rng = ActiveSheet.UsedRange.Address End Sub diff --git a/src/code/bUTL.cls b/src/code/bUTL.cls deleted file mode 100644 index e0ffa54..0000000 --- a/src/code/bUTL.cls +++ /dev/null @@ -1,17 +0,0 @@ -VERSION 1.0 CLASS -BEGIN - MultiUse = -1 'True -END -Attribute VB_Name = "bUTL" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = False -Attribute VB_PredeclaredId = False -Attribute VB_Exposed = False -'--------------------------------------------------------------------------------------- -' Module : bUTL -' Author : @byronwall -' Date : 2015 08 12 -' Purpose : Code has been removed with the text boxes. Module might be deleted next. -'--------------------------------------------------------------------------------------- - -Option Explicit diff --git a/src/code/bUTLChartSeries.cls b/src/code/bUTLChartSeries.cls index cca11a5..cdc36dc 100644 --- a/src/code/bUTLChartSeries.cls +++ b/src/code/bUTLChartSeries.cls @@ -25,38 +25,37 @@ Public series As series Private str_name As String -'--------------------------------------------------------------------------------------- -' Procedure : AddSeriesToChart -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Adds the represented series to a chart -'--------------------------------------------------------------------------------------- -' -Function AddSeriesToChart(cht As Chart) As series - Dim ser As series - Set ser = cht.SeriesCollection.newSeries +Function AddSeriesToChart(cht As Chart) As series + '--------------------------------------------------------------------------------------- + ' Procedure : AddSeriesToChart + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Adds the represented series to a chart + '--------------------------------------------------------------------------------------- + ' + Dim chtSeries As series + Set chtSeries = cht.SeriesCollection.NewSeries - ser.Formula = Me.SeriesFormula + chtSeries.Formula = Me.SeriesFormula If Me.ChartType <> 0 Then - ser.ChartType = Me.ChartType + chtSeries.ChartType = Me.ChartType End If - - Set AddSeriesToChart = ser + Set AddSeriesToChart = chtSeries End Function -'--------------------------------------------------------------------------------------- -' Procedure : FullAddress -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Gets the full address for a range -'--------------------------------------------------------------------------------------- -' -Private Function FullAddress(rng As Range) As Variant +Private Function FullAddress(rng As Range) As Variant + '--------------------------------------------------------------------------------------- + ' Procedure : FullAddress + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Gets the full address for a range + '--------------------------------------------------------------------------------------- + ' If rng Is Nothing Then FullAddress = "" Else @@ -65,15 +64,15 @@ Private Function FullAddress(rng As Range) As Variant End Function -'--------------------------------------------------------------------------------------- -' Procedure : SeriesFormula -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Returns a SERIES formula for the represented series -'--------------------------------------------------------------------------------------- -' -Public Property Get SeriesFormula() As String +Public Property Get SeriesFormula() As String + '--------------------------------------------------------------------------------------- + ' Procedure : SeriesFormula + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Returns a SERIES formula for the represented series + '--------------------------------------------------------------------------------------- + ' '2015 11 09 add a trap here to allow for a string only name If str_name <> "" Then SeriesFormula = "=SERIES(" & str_name & "," & _ @@ -88,26 +87,29 @@ Public Property Get SeriesFormula() As String End Property -'--------------------------------------------------------------------------------------- -' Procedure : Class_Initialize -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Ensures the SERIES starts out first -'--------------------------------------------------------------------------------------- -' + Private Sub Class_Initialize() + '--------------------------------------------------------------------------------------- + ' Procedure : Class_Initialize + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Ensures the SERIES starts out first + '--------------------------------------------------------------------------------------- + ' Me.SeriesNumber = 1 End Sub -'--------------------------------------------------------------------------------------- -' Procedure : UpdateFromChartSeries -' Author : @byronwall -' 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 + '--------------------------------------------------------------------------------------- + ' Procedure : UpdateFromChartSeries + ' Author : @byronwall + ' Date : 2015 11 09 + ' Purpose : Reads the series info from a Series and stores it in the class + '--------------------------------------------------------------------------------------- + ' + + 'this will work for the simple case where all items are references Set series = ser @@ -161,15 +163,15 @@ Sub UpdateFromChartSeries(ser As series) Me.ChartType = ser.ChartType End Sub -'--------------------------------------------------------------------------------------- -' Procedure : UpdateSeriesWithNewValues -' Author : @byronwall -' Date : 2015 07 24 -' Purpose : Forces the stored Series to take on any changed values in the class -'--------------------------------------------------------------------------------------- -' -Sub UpdateSeriesWithNewValues() +Sub UpdateSeriesWithNewValues() + '--------------------------------------------------------------------------------------- + ' Procedure : UpdateSeriesWithNewValues + ' Author : @byronwall + ' Date : 2015 07 24 + ' Purpose : Forces the stored Series to take on any changed values in the class + '--------------------------------------------------------------------------------------- + ' Me.series.Formula = Me.SeriesFormula End Sub diff --git a/src/code/bUTL_About.bas b/src/code/bUTL_About.bas new file mode 100644 index 0000000..271f988 --- /dev/null +++ b/src/code/bUTL_About.bas @@ -0,0 +1,6 @@ +Attribute VB_Name = "bUTL_About" +Option Explicit + +Public Function bUTL_GetVersion() As String + bUTL_GetVersion = "1.0" +End Function diff --git a/src/code/form_chtGrid.frm b/src/code/form_chtGrid.frm index 07708ce..8e60cab 100644 --- a/src/code/form_chtGrid.frm +++ b/src/code/form_chtGrid.frm @@ -20,7 +20,6 @@ Attribute VB_Exposed = False - '--------------------------------------------------------------------------------------- ' Module : form_chtGrid ' Author : @byronwall diff --git a/src/code/form_chtGrid.frx b/src/code/form_chtGrid.frx index 8fe481e..30ce16c 100644 Binary files a/src/code/form_chtGrid.frx and b/src/code/form_chtGrid.frx differ diff --git a/src/code/form_chtSeries.frm b/src/code/form_chtSeries.frm index f33352d..40f3293 100644 --- a/src/code/form_chtSeries.frm +++ b/src/code/form_chtSeries.frm @@ -17,6 +17,7 @@ Attribute VB_Exposed = False + Option Explicit '--------------------------------------------------------------------------------------- @@ -34,7 +35,7 @@ Private Sub btn_setXRange_Click() 'get the selected series - Dim i As Integer + Dim i As Long For i = 0 To list_series.ListCount - 1 If list_series.Selected(i) Then @@ -65,7 +66,7 @@ Private Sub btn_ydown_Click() End Sub Private Sub btn_yrange_Click() - Dim i As Integer + Dim i As Long For i = 0 To list_series.ListCount - 1 If list_series.Selected(i) Then @@ -111,17 +112,17 @@ Private Sub UpdateSeries() 'clean up the mess ser_coll.RemoveAll - Dim i As Integer + Dim i As Long For i = list_series.ListCount - 1 To 0 Step -1 list_series.RemoveItem (i) Next i - Dim cht_obj As ChartObject + Dim chtObj As ChartObject Dim ser As series - For Each cht_obj In Chart_GetObjectsFromObject(Selection) - For Each ser In cht_obj.Chart.SeriesCollection + For Each chtObj In Chart_GetObjectsFromObject(Selection) + For Each ser In chtObj.Chart.SeriesCollection Dim b_ser As bUTLChartSeries Set b_ser = New bUTLChartSeries @@ -132,7 +133,13 @@ Private Sub UpdateSeries() ser_name = IIf(Not b_ser.name Is Nothing, b_ser.name, "") list_series.AddItem + If IsArray(ser_name) Then + ser_name = ser_name(1, 1) + End If + list_series.List(list_series.ListCount - 1, 0) = ser_name + + list_series.List(list_series.ListCount - 1, 1) = b_ser.XValues.Address list_series.List(list_series.ListCount - 1, 2) = b_ser.Values.Address @@ -141,7 +148,7 @@ Private Sub UpdateSeries() ser_coll.Add list_series.ListCount - 1 & ser_name, b_ser Next ser - Next cht_obj + Next chtObj End Sub Private Sub UserForm_Activate() diff --git a/src/code/form_chtSeries.frx b/src/code/form_chtSeries.frx index 3dc3441..48437ae 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 49287ab..4ba2248 100644 --- a/src/code/form_newCommands.frm +++ b/src/code/form_newCommands.frm @@ -1,7 +1,7 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} form_newCommands Caption = "Additional Features" - ClientHeight = 8460 + ClientHeight = 10290 ClientLeft = 45 ClientTop = 435 ClientWidth = 6585 @@ -18,6 +18,7 @@ Attribute VB_Exposed = False + Option Explicit '--------------------------------------------------------------------------------------- @@ -105,3 +106,21 @@ End Sub Private Sub CommandButton32_Click() Chart_CreateChartWithSeriesForEachColumn End Sub + +Private Sub CommandButton33_Click() + CopyDiscontinuousRangeValuesToClipboard +End Sub + +Private Sub CommandButton34_Click() + Formula_CreateCountNameForArray +End Sub + +Private Sub CommandButton35_Click() + TraceDependentsForAll + Unload Me +End Sub + +Private Sub CommandButton37_Click() + Unload Me + PadWithSpaces +End Sub diff --git a/src/code/form_newCommands.frx b/src/code/form_newCommands.frx index 2e48178..f4bc4d5 100644 Binary files a/src/code/form_newCommands.frx and b/src/code/form_newCommands.frx differ diff --git a/src/package/customUI/customUI.xml b/src/package/customUI/customUI.xml index e4d38e6..fa8d150 100644 --- a/src/package/customUI/customUI.xml +++ b/src/package/customUI/customUI.xml @@ -358,6 +358,11 @@ label="about" supertip="This will open the GitHub page for bUTL." onAction="btn_aboutForm_onAction"/> +