From 18afa1319ef2c0e5ef08a59aa9a49e374ab5445e Mon Sep 17 00:00:00 2001 From: byron wall Date: Fri, 4 Dec 2015 14:49:42 -0700 Subject: [PATCH] add'l charting code, changes to distance This adds a couple more charting functions and improves the distance matrix calculation. --- src/code/Chart_Processing.bas | 51 +++++++++++++++++++++++ src/code/Testing.bas | 76 +++++++++++++++++++++++++++++----- src/code/form_newCommands.frm | 12 +++++- src/code/form_newCommands.frx | Bin 5656 -> 5656 bytes 4 files changed, 127 insertions(+), 12 deletions(-) diff --git a/src/code/Chart_Processing.bas b/src/code/Chart_Processing.bas index c6019d6..da2acd5 100644 --- a/src/code/Chart_Processing.bas +++ b/src/code/Chart_Processing.bas @@ -8,6 +8,57 @@ Attribute VB_Name = "Chart_Processing" Option Explicit +Public Sub Chart_CreateChartWithSeriesForEachColumn() +'will create a chart that includes a series with no x value for each column + + Dim rng_data As Range + Set rng_data = GetInputOrSelection("Select chart data") + + 'create a chart + Dim cht_obj As ChartObject + Set cht_obj = ActiveSheet.ChartObjects.Add(0, 0, 300, 300) + + cht_obj.Chart.ChartType = xlXYScatter + + Dim rng_col As Range + For Each rng_col In rng_data.Columns + + Dim rng_chart As Range + Set rng_chart = RangeEnd(rng_col.Cells(1, 1), xlDown) + + Dim b_ser As New bUTLChartSeries + Set b_ser.Values = rng_chart + + b_ser.AddSeriesToChart cht_obj.Chart + Next + +End Sub + +Public Sub Chart_CopyToSheet() + + Dim cht_obj As ChartObject + + Dim obj_all As Object + Set obj_all = Selection + + Dim msg_newSheet As VbMsgBoxResult + msg_newSheet = MsgBox("New sheet?", vbYesNo, "New sheet?") + + Dim sht_out As Worksheet + If msg_newSheet = vbYes Then + Set sht_out = Worksheets.Add() + Else + Set sht_out = Application.InputBox("Pick a cell on a sheet", "Pick sheet", Type:=8).Parent + End If + + For Each cht_obj In Chart_GetObjectsFromObject(obj_all) + cht_obj.Copy + + sht_out.Paste + Next + + sht_out.Activate +End Sub Sub Chart_SortSeriesByName() 'this will sort series by names diff --git a/src/code/Testing.bas b/src/code/Testing.bas index bbeeaea..309c564 100644 --- a/src/code/Testing.bas +++ b/src/code/Testing.bas @@ -9,7 +9,7 @@ Public Sub ComputeDistanceMatrix() '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 Application.Calculation = xlCalculationManual @@ -19,12 +19,56 @@ Public Sub ComputeDistanceMatrix() Dim wkbk As Workbook Set wkbk = Workbooks.Add + Dim sht_out As Worksheet + Set sht_out = wkbk.Sheets(1) + sht_out.name = "scaled data" + + 'copy data over to standardize + rng_input.Copy wkbk.Sheets(1).Range("A1") + + 'go to edge of data, add a column, add STANDARDIZE, copy paste values, delete + + Dim rng_data As Range + Set rng_data = sht_out.Range("A1").CurrentRegion + + Dim rng_col As Range + For Each rng_col In rng_data.Columns + + 'edge cell + Dim rng_edge As Range + Set rng_edge = sht_out.Cells(1, sht_out.Columns.count).End(xlToLeft).Offset(, 1) + + 'do a normal dist standardization + '=STANDARDIZE(A1,AVERAGE(A:A),STDEV.S(A:A)) + + rng_edge.Formula = "=IFERROR(STANDARDIZE(" & rng_col.Cells(1, 1).Address(False, False) & ",AVERAGE(" & _ + rng_col.Address & "),STDEV.S(" & rng_col.Address & ")),0)" + + 'do a simple value over average to detect differences + rng_edge.Formula = "=IFERROR(" & rng_col.Cells(1, 1).Address(False, False) & "/AVERAGE(" & _ + rng_col.Address & "),1)" + + 'fill that down + Range(rng_edge, rng_edge.Offset(, -1).End(xlDown).Offset(, 1)).FillDown + + Next + + Application.Calculate + sht_out.UsedRange.Value = sht_out.UsedRange.Value + rng_data.EntireColumn.Delete + + Dim sht_dist As Worksheet + Set sht_dist = wkbk.Worksheets.Add() + sht_dist.name = "distances" + Dim rng_out As Range - Set rng_out = wkbk.Sheets(1).Range("A1") + Set rng_out = sht_dist.Range("A1") 'loop through each row with each other row Dim rng_row1 As Range Dim rng_row2 As Range + + Set rng_input = sht_out.Range("A1").CurrentRegion For Each rng_row1 In rng_input.Rows For Each rng_row2 In rng_input.Rows @@ -40,11 +84,11 @@ Public Sub ComputeDistanceMatrix() 'take the sqrt of that value and output rng_out.Value = dbl_dist_sq ^ 0.5 - + 'get to next column for output Set rng_out = rng_out.Offset(, 1) Next - + 'drop down a row and go back to left edge Set rng_out = rng_out.Offset(1).End(xlToLeft) Next @@ -52,6 +96,12 @@ Public Sub ComputeDistanceMatrix() Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True + + sht_dist.UsedRange.NumberFormat = "0.00" + sht_dist.UsedRange.EntireColumn.AutoFit + + 'do the coloring + Formatting_AddCondFormat sht_dist.UsedRange End Sub @@ -61,20 +111,23 @@ Sub RemoveAllLegends() For Each cht_obj In Chart_GetObjectsFromObject(Selection) cht_obj.Chart.HasLegend = False - cht_obj.Chart.HasTitle = False + cht_obj.Chart.HasTitle = True + + cht_obj.Chart.SeriesCollection(1).MarkerSize = 4 Next End Sub Sub ApplyFormattingToEachColumn() -' -' Macro1 Macro -' - -' Dim rng As Range For Each rng In Selection.Columns + Formatting_AddCondFormat rng + Next +End Sub + +Private Sub Formatting_AddCondFormat(ByVal rng As Range) + rng.FormatConditions.AddColorScale ColorScaleType:=3 rng.FormatConditions(rng.FormatConditions.count).SetFirstPriority rng.FormatConditions(1).ColorScaleCriteria(1).Type = _ @@ -96,9 +149,10 @@ Sub ApplyFormattingToEachColumn() .Color = 8109667 .TintAndShade = 0 End With - Next End Sub + + '--------------------------------------------------------------------------------------- ' Procedure : TraceDependentsForAll ' Author : @byronwall diff --git a/src/code/form_newCommands.frm b/src/code/form_newCommands.frm index 6811023..f9ab8f7 100644 --- a/src/code/form_newCommands.frm +++ b/src/code/form_newCommands.frm @@ -1,11 +1,12 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} form_newCommands Caption = "Additional Features" - ClientHeight = 7770 + ClientHeight = 8460 ClientLeft = 45 ClientTop = 435 ClientWidth = 6585 OleObjectBlob = "form_newCommands.frx":0000 + ShowModal = 0 'False StartUpPosition = 1 'CenterOwner End Attribute VB_Name = "form_newCommands" @@ -13,6 +14,7 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False + Option Explicit '--------------------------------------------------------------------------------------- @@ -92,3 +94,11 @@ End Sub Private Sub CommandButton30_Click() ApplyFormattingToEachColumn End Sub + +Private Sub CommandButton31_Click() + ComputeDistanceMatrix +End Sub + +Private Sub CommandButton32_Click() + Chart_CreateChartWithSeriesForEachColumn +End Sub diff --git a/src/code/form_newCommands.frx b/src/code/form_newCommands.frx index dcb2fc8014e1211d6556ff2a3166e7550c20d13e..1b966ac286addf2b9635a4ff8942c8decd88f004 100644 GIT binary patch delta 477 zcmZWlO-lk%6uqOPj5^hrR*NtmrWG~jSBbQVvNloVG9rjUCluzx#*w6`{0Y%3aML1M zv?)s5v~1PBR&HAM4_Z6j(OUK3y!+lc=e~EiO|dCn1Rc-e)~Lpg2(#B`pY!jG695_m zxZygWE5T*jVY8k9+h_D1v*XG-UO0N`I`%Ihuk|%xutsUfeJ+IYG>M2Hx|U_p2X`bC z$4df{M5GXDge@-GwRJehOaL1Jju-eSGL{99!3w7U`!RrxC7R)4-XJoscE+o=%Dpkn z6BT?@bl01wgT5L1;eAA=;X7d*J-*9(smSLTf4joF*mcJyh}b#~4Zu$uIbE&POnI$b zH6^VeZ%L+6u9Fx!Dk};p7_wx_L?XpsnW#OzjvuAyw?~NQWh196HC4lwzPpO{LP;`A ze8Mb|s%(_yDyhf@Dd-B_7ErH;;R{DKgbD2VD2QS31Ex_Wt+-kwKce+_O#lD@ delta 250 zcmbQCGec*B2-83LjbeE$q8pwIEqtJRk&&5!fx&?XNB}|F}S0c7!{&AA-M7#Ue7 z3vjDVj^YYn`u`uyyu`H@DA>SV%?RQD