' If it didn't get worse, adjust to new positionĭPoints(i).DataLabel.Left = xArr(i) - wArr(i) / 2ĭPoints(i).DataLabel. If Abs(newX - pArr(j)) < wArr(i) / 2 + mArr(j) _Īnd Abs(newY - qArr(j)) < hArr(i) / 2 + mArr(j) ThenĭE = dE - wgtDistance / ((xArr(i) - xArr(j)) ^ 2 + (yArr(i) - yArr(j)) ^ 2)ĭE = dE + wgtDistance / ((newX - xArr(j)) ^ 2 + (newY - yArr(j)) ^ 2)ĭE = dE - wgtClose * (Abs(xArr(i) - pArr(i)) + Abs(yArr(i) - qArr(i)))ĭE = dE + wgtClose * (Abs(newX - pArr(i)) + Abs(newY - qArr(i))) If Abs(xArr(i) - pArr(j)) < wArr(i) / 2 + mArr(j) _Īnd Abs(yArr(i) - qArr(j)) < hArr(i) / 2 + mArr(j) Then If 2 * Abs(newX - xArr(j)) < wArr(i) + wArr(j) _Īnd 2 * Abs(newY - yArr(j)) < hArr(i) + hArr(j) ThenĭE = dE + Abs(newX - xArr(j) + (wArr(i) + wArr(j)) / 2) _ NewY = qArr(i) + hArr(i) / 2 + mArr(i) / 2 NewY = qArr(i) - hArr(i) / 2 - mArr(i) / 2 NewX = pArr(i) + wArr(i) * Cos(theta) / 2 If Abs(Sin(theta) * wArr(i)) > Abs(hArr(i) * Cos(theta)) Then ' Determine the position it would shift to Sub RearrangeScatterLabels(plot As Chart, Optional timelimit As Double = 5) RearrangeScatterLabels ActiveSheet.ChartObjects(1).Chart, 3 There are some issues with the borders and the axis labels which maybe I'll account for later.
The results aren't great for my own data set, but I think it can be tuned easily for most usages. I've left quite a few notes around to help read it, should anyone choose to continue this project.īuilding on your function, I made a routine to randomly reposition the labels, assigning a score according to how much overlap it would cause, and thusly optimize.
#Xy scatter plot excel 2010 data labels in cmp math code
I realize the code is kinda rough and not optimized, but I can't spend more time on this project. If UBound(dLabels) = BxL And AyT = ByT) 'Reverse De Morgan's LawĭetectOverlap = Not (AxL >= BxL And AxR = ByT And AyB <= ByB) 'Is in chart bounds (working in IV quadrant) YArr(i) = temp(2) 'Store all points y values XArr(i) = temp(0) 'Store all points x values If I just select the datapoints it plots a XY intercept point but with no labels. Temp = getElementDimensions(, dPoints(i)) Please see the attached image - if I select all the data the Scattergraph gives me two lines with the labels. Set dPoints(i) = sCollection(i).Points(pt) 'Store all point objects Set dLabels(i) = sCollection(i).Points(pt).DataLabel 'Store all label objects
ReDim Preserve yArr(1 To UBound(yArr) + 1) ReDim Preserve xArr(1 To UBound(xArr) + 1) ReDim Preserve dPoints(1 To UBound(dPoints) + 1)
ReDim Preserve dLabels(1 To UBound(dLabels) + 1) Set sCollection = plot.SeriesCollection 'All points and labelsįor pt = 1 To sCollection(1).Points.Count Set plot = sht.ChartObjects(1).Chart 'XY chart (scatter plot) Sub RearrangeScatterLabels(sht As Worksheet)ĭim xArr(), yArr(), stDevX, stDevY As Doubleĭim safetyNet, validEntry, currentPoint As Integer Const PIXEL_TO_POINT_RATIO As Double = 0.72 '1 Pixel = 72/96*1 Point
0 kommentar(er)
