I have a DevExpress XtraChart object with several series, all of type: line.
I have a requirement from a client to align the series by the max value of each series. This is without regard to the attached axis, has anyone done this before?
Although I was interested in displaying this on the chart element, the 'work' was done on the underlying DataSet.
I was able to achieve this by looping through the series collection, deriving the max value of the first series, through a SQL query, and then each subsequent series, and noting the difference, and then adding or subtracting the difference at the DataSet level.
Here's the code:
Private Sub cbAlignPeaks_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cbAlignPeaks.CheckedChanged
Dim dt As DataTable = chart.DataSource
Dim Row() As Data.DataRow
Dim s As Series = Nothing
Dim dtr As DataTableReader = Nothing
Dim maxTimeGet, maxTimeSet, diff As Decimal
Me.Cursor = Cursors.WaitCursor
If cbAlignPeaksPre.Checked Then
For i As Integer = 0 To chartPreTim.Series.Count - 1
s = chartPreTim.Series(i)
If _offsets.Count = chartPreTim.Series.Count - 1 Then
If i > 0 Then
diff = _offsets(s.DataFilters(0).Value)
Row = dt.Select("BORING_NAME = '" & s.Name & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") + diff
Next
End If
Else
If i = 0 Then 'get adjustment info
dtr = getDetectorMax(s.DataFilters(0).Value, cbDetectors.Text, timType.PRE) ' <-- getDetectorMax runs a SQL query returning the max value
If dtr.Read Then
maxTimeGet = dtr("TIME_SEC")
End If
Else 'set adjustment info
dtr = Nothing
dtr = getDetectorMax(s.DataFilters(0).Value, cbDetectors.Text, timType.PRE)
If dtr.Read Then
maxTimeSet = dtr("TIME_SEC")
End If
If maxTimeGet > maxTimeSet Then
diff = maxTimeGet - maxTimeSet
_offsets.Add(s.DataFilters(0).Value, diff)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") + diff
Next
Else
diff = maxTimeSet - maxTimeGet
_offsets.Add(s.DataFilters(0).Value, diff * -1)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") - diff
Next
End If
End If
End If
Next
Else
For i As Integer = 1 To chartPreTim.Series.Count - 1 ' We skip item 0 as that's the baseline
s = chartPreTim.Series(i)
diff = _offsets(s.DataFilters(0).Value)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") - diff
Next
Next
End If
chartPreTim.RefreshData()
chartPreTim.Refresh()
Me.Cursor = Cursors.Default
End Sub
Related
Could you anybody help me how to split word file by character!
I can't find any way to split word files by the number of characters on the internet!
For example, to split a document into 500-character blocks:
Sub SplitDocument()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, j As Long
Const Char As Long = 500
With ActiveDocument
' Process each character block
For i = 1 To Int(.Characters.Count / Char)
j = j + 1
' Get the character block
Set Rng = .Range((i - 1) * Char, i * Char)
' Copy the character block
Rng.Copy
Rng.Collapse wdCollapseEnd
Call NewDoc(ActiveDocument, (i - 1) * Char + 1, j)
Next
If Rng.End < .Range.End Then
i = i + 1: j = j + 1
Rng.End = .Range.End
' Copy the range
Rng.Copy
Rng.Collapse wdCollapseEnd
Call NewDoc(ActiveDocument, (i - 1) * Char + 1, j)
End If
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub NewDoc(DocSrc As Document, i As Long, j As Long)
Dim DocTgt As Document, HdFt As HeaderFooter
' Create the output document
Set DocTgt = Documents.Add(Visible:=False)
With DocTgt
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Replicate the headers & footers
For Each HdFt In DocSrc.Sections(DocSrc.Characters(i).Sections(1).Index).Headers
.Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In DocSrc.Sections(DocSrc.Characters(i).Sections(1).Index).Footers
.Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=Split(DocSrc.FullName, ".doc")(0) & "_" & j & ".docx", _
FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Set DocTgt = Nothing: Set DocSrc = Nothing
End Sub
I have a problem with my code, I want to evaluate a Report with Charts.
What my Macro currently does is, Create for every single column a Row for a nominal, upper, lower tolerance. Then It creates with this values a chart.
After this it starts with the Sorting and then it removes the Marker Points, but here my Problems already start.
I would like to create the charts later for example on pos A100 or A50 or something.
Then the Marker Points, I would like to keep the Points on the result line but not on the 3 created, but I found no way
Remove the Markers, but it removes all, i would really like to remove them only for
FullSeriesCollection(2).format.Line
FullSeriesCollection(3).format.Line
FullSeriesCollection(4).format.Line
Would be nice if someone would have an idea.. :)
Thanks in advance,
' Unload UFormTools
UFormTools.Hide
Application.ScreenUpdating = False
Sheets("Original Values").Select
Dim lngC As Long, lngR As Long
Dim i As Long
Dim c As Byte
Application.ScreenUpdating = False
With ActiveSheet
lngC = (.Cells(17, 4).End(xlToRight).Column - 4) * 4
For i = 4 To lngC Step 4
lngR = .Cells(.Rows.Count, i).End(xlUp).Row
For c = 1 To 3
.Columns(i + c).EntireColumn.Insert
Next c
.Cells(17, i).AutoFill Destination:=.Range(.Cells(17, i), .Cells(17, i + 3)), Type:=xlFillCopy
.Range(.Cells(28, i + 1), .Cells(lngR, i + 1)).Value = .Cells(18, i).Value
.Range(.Cells(28, i + 2), .Cells(lngR, i + 2)).Value = .Cells(18, i).Value + .Cells(19, i).Value
.Range(.Cells(28, i + 3), .Cells(lngR, i + 3)).Value = .Cells(18, i).Value + .Cells(20, i).Value
.Shapes.AddChart2(332, xlLineMarkers).Select
With ActiveChart
.SetSourceData Source:=Union(ActiveSheet.Range(ActiveSheet.Cells(17, i), ActiveSheet.Cells(17, i + 3)), _
ActiveSheet.Range(ActiveSheet.Cells(28, i), ActiveSheet.Cells(lngR, i + 3)))
' .Legend.Delete
.ChartTitle.Text = ActiveSheet.Cells(17, i).Value
.ChartTitle.format.TextFrame2.TextRange.Characters.Text = ActiveSheet.Cells(17, i).Value
With .ChartTitle.format.TextFrame2.TextRange.Characters(1, Len(ActiveSheet.Cells(17, i).Value)).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With .FullSeriesCollection(3).format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With .FullSeriesCollection(4).format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With .FullSeriesCollection(2).format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Visible = msoTrue
.DashStyle = msoLineDash
.Weight = 1.5
End With
With .FullSeriesCollection(1).format.Line
.Visible = msoTrue
.Weight = 3
End With
.FullSeriesCollection(1).Smooth = True
.Axes(xlValue).MinimumScaleIsAuto = True
.Axes(xlValue).MinimumScaleIsAuto = True
End With
Next i
End With
' Sort and Arrange Charts, but another Position to Start would be nice.. (for example A100)
Dim MyWidth As Single, MyHeight As Single
Dim NumWide As Long
Dim iChtIx As Long, iChtCt As Long
MyWidth = 300
MyHeight = 200
NumWide = 4
iChtCt = ActiveSheet.ChartObjects.Count
For iChtIx = 1 To iChtCt
With ActiveSheet.ChartObjects(iChtIx)
.Width = MyWidth
.Height = MyHeight
.Left = ((iChtIx - 1) Mod NumWide) * MyWidth
.Top = Int((iChtIx - 1) / NumWide) * MyHeight
End With
Next
' Remove the Markers, but it removes all, i would really like to remove them only for
' FullSeriesCollection(2).format.Line
' FullSeriesCollection(3).format.Line
' FullSeriesCollection(4).format.Line
Dim cht As ChartObject
Dim srs As Series
Dim MarkerCount As Long
For Each cht In ActiveSheet.ChartObjects
cht.Activate
For Each srs In ActiveChart.SeriesCollection
If srs.MarkerStyle <> xlMarkerStyleNone Then
srs.MarkerStyle = xlMarkerStyleNone
MarkerCount = MarkerCount + 1
End If
Next srs
Next cht
Range("A1").Select
Application.ScreenUpdating = True
This one has me stumped. I am populating a Listbox with a range and then formatting column 4 as d/mm/yyyy. This works fine if all cells in column 4 have a date. As some cells that are populated into the Listbox are in fact blank the sub crashes when it hits these cells. I have tried various if and else statements to skip the activecell if blank with no luck.
Grateful for any assistance.
Alex V
Sub populate_listbox_1()
Dim I As Long
Dim I2 As Long
Dim list_count As Long
Dim MyData As Range
Dim r As Long
With edit_report_input.compliments_listbox
.ColumnCount = 17
.ColumnWidths = "70;300;75;90;80;80;100;0;0;0;0;0;0;0;0;20;0"
.RowSource = ""
Set MyData = ActiveSheet.Range("A4:Q498") 'Adjust the range accordingly
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 1) = "" Then
.RemoveItem r
End If
Next r
End With
For I = 0 To edit_report_input.compliments_listbox.ListCount - 1
edit_report_input.compliments_listbox.List(I, 4) = Format(DateValue(edit_report_input.compliments_listbox.List(I, 4)), "d/mm/yyyy")
Next I
date_rec_compliment = Format(date_rec_compliment, "d/mm/yyyy")
End Sub
you can always check before changing the format. See if below snippet helps
For I = 0 To edit_report_input.compliments_listbox.ListCount - 1
if edit_report_input.compliments_listbox.List(I, 4) <> "" Then
edit_report_input.compliments_listbox.List(I, 4) = Format(DateValue(edit_report_input.compliments_listbox.List(I, 4)), "d/mm/yyyy")
End If
Next I
I have a select distinct query that works find on selected fields from a listbox. However I would like it to be a count distinct and I can't seem to get the code right. Below is my working code for select distinct. Thanks in advance for any assistance I've searched for count distinct questions but I don't see any specific to listbox selections.
Private Sub CmdDistinctVal_Click()
Dim cn1 As ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim cmd1 As New ADODB.Command
Dim varItem As Variant
Dim aFields() As aArray
Dim NumRows As Integer
Dim NumFields As Integer
Dim colcount As Integer
Dim colwidths As String
Dim strRow As String
Dim cnt1 As Integer
Dim cnt2 As Integer
'On Error GoTo Err_ CmdDistinctVal_Click
'cmd1.ActiveConnection = CurrentProject.Connection
Me.DistinctResultsFldVal.RowSource = ""
ReDim aFields(50)
For cnt1 = 1 To 50
ReDim aFields(cnt1).fValue(6000)
Next
NumRows = 0
colcount = 0
For Each varItem In Me!ResultsFieldList.ItemsSelected
colcount = colcount + 1
aFields(colcount).fName = Me!ResultsFieldList.ItemData(varItem)
NumFields = 0
rs1.Open "SELECT DISTINCT " & Me!ResultsFieldList.ItemData(varItem) & "
FROM [Results Report]", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rs1.RecordCount > NumRows Then NumRows = rs1.RecordCount
strRow = strRow & Me!ResultsFieldList.ItemData(varItem) & ";"
While Not rs1.EOF
NumFields = NumFields + 1
If NumFields > NumRows Then
NumRows = NumFields
End If
aFields(colcount).fValue(NumFields) = rs1(0) & ""
rs1.MoveNext
Wend
rs1.Close
Next varItem
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.ColumnCount = colcount
Me.DistinctResultsFldVal.ColumnWidths = Mid(colwidths, 2)
Me.DistinctResultsFldVal.AddItem (strRow)
For cnt1 = 1 To NumRows
strRow = ""
For cnt2 = 1 To colcount
If aFields(cnt2).fValue(cnt1) = "" Then
strRow = strRow & ";"
Else
strRow = strRow & aFields(cnt2).fValue(cnt1) & ";"
End If
Next
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.AddItem (strRow)
Next
'Err_ CmdDistinctVal_Click:
'MsgBox "All null values were found in one or more of your selected fields"
End Sub
I'm trying to copy and paste a range, to create a 28 by 28 grid of numbers "rotating" the values so that each time the range is pasted into the next column, the range is moves down by one row and the last value "overflows" back to the top of the next row, I've got this far but am stumped on the overflow part (i' relative newbie to VBA)
Sub Test()
Dim oRange As Range
Set oRange = ActiveSheet.Range("A1:A28")
Dim i As Integer
For i = 1 To 28
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Next i
End Sub
Also I need to copy and paste values and formatting of the cells
Hope you guys can help
Thanks
Dan
Sub Test()
Dim oRange As Range
Dim startColumn As String
Dim rangeStart As Integer
Dim rangeEnd As Integer
Dim cellCount As Integer
Dim i As Integer
startColumn = "A"
rangeStart = 1
rangeEnd = 28
cellCount = rangeEnd - rangeStart + 1
For i = 1 To cellCount - 1
Set oRange = ActiveSheet.Range(startColumn & rangeStart & _
":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.Range(startColumn & (rangeEnd - i + 1) & _
":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellCount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
EDIT:
to insert a blanck row at index 'i':
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
to insert 5 rows at the top of the worksheet insert a row 5 times at index 1:
For i = 1 To 5
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Next