Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.
''' Code for the correl Function
Public Function Corell()
Dim objApp As Excel.Application
Dim objBook As Workbook
Dim objSheet As Worksheet
On Error Resume Next
Set objApp = GetObject("excel.application")
If Err.Number <> 0 Then
Set objApp = CreateObject("excel.application")
End If
Set objBook = objApp.Workbooks.Add
Set objSheet = objApp.Sheets(1)
Dim j As Integer, high As Integer
'This would be the number of data elements
If keeling_Select = True Then
high = therowsel
'High = cbo_RowSelected.List(cbo_RowSelected.ListCount - 1) 'cbo_RowSelected.ListCount - 1
'For j = cbo_RowSelected.List(0) To cbo_RowSelected.List(cbo_RowSelected.ListCount - 1)
For j = therow To high
objSheet.Cells(j, 1).value = grd_result.TextMatrix(j, 2)
objSheet.Cells(j, 2).value = grd_result.TextMatrix(j, 3)
For thecol = 1 To grd_result.Cols - 1 'RS_find.Fields.Count
grd_result.Col = thecol
grd_result.ColSel = thecol
grd_result.Row = j
grd_result.CellBackColor = &HFFFF&
Next thecol
Next
Else
Dim i As Integer
high = i ' grd_result.Rows - 1
i = 2
For j = 1 To grd_result.Rows - 1
high = i
objSheet.Cells(j, 1).value = grd_result.TextMatrix(j, 2)
objSheet.Cells(j, 2).value = grd_result.TextMatrix(j, 3)
i = i + 1
objSheet.Range("a" & high + 1 & ":a" & high + 1).formula = "=Correl(a1:a" & high & ", b1:b" & high & ")^2"
result = FormatNumber(CDbl(objSheet.Range("a" & high + 1 & ":A" & high + 1).value), 5, vbTrue)
Debug.Print (result)
Next
End If
' objSheet.Range("a" & high + 1 & ":a" & high + 1).formula = "=Correl(a1:a" & high & ", b1:b" & high & ")^2"
' result = FormatNumber(CDbl(objSheet.Range("a" & high + 1 & ":A" & high + 1).value), 5, vbTrue)
'
'MsgBox result
objApp.DisplayAlerts = False
Set objSheet = Nothing
Set objBook = Nothing
objApp.Quit
Set objApp = Nothing
End Function
''' Code for Max function
Sub MaxValue()
Dim rg As Range
Dim MaxVal As Double
Dim MaxRow As Long, MaxCol As Long
Dim sName As String
Set rg = Selection
MaxVal = Application.Max(rg)
MaxRow = rg.Find(MaxVal, lookat:=xlWhole, LookIn:=xlValues).Row
MaxCol = rg.Find(MaxVal, lookat:=xlWhole, LookIn:=xlValues).Column
sName = rg.Cells(MaxRow - rg.Row + 1, 1)
[AA1:AA4].Value = Application.Transpose(Array(MaxVal, MaxRow, MaxCol, sName))
End Sub
''' Code for Exporting format and Chart to excel
Private Sub cmd_OutputKeelingPlot_Click()
Dim objApp As Excel.Application
Dim objBook As Workbook
Dim objSheet As Worksheet
Dim objExcelCI As Excel.Chart
On Error Resume Next
Set objApp = GetObject("excel.application")
If Err.Number <> 0 Then
Set objApp = CreateObject("excel.application")
End If
Set objBook = objApp.Workbooks.Add
Set objSheet = objApp.Sheets(1)
objApp.Visible = True
objApp.UserControl = True
objApp.WindowState = xlMaximized
objApp.DisplayAlerts = False
With objSheet
.Cells(1, 1).value = " Starting Date "
.Cells(1, 2).value = " Ending Date "
.Cells(1, 3).value = " Plot Date "
.Cells(1, 4).value = " n "
.Cells(1, 5).value = " R-squared "
.Cells(1, 6).value = " Standard Error "
.Cells(1, 7).value = " Slope "
.Cells(1, 8).value = " Standard Error "
.Cells(1, 9).value = " Y-intercept "
.Cells(1, 10).value = " Standard Error "
''' Have the code for the loop that gives all the values to these columns and defiens the range
.Range("A1:k1").Select
With Selection
.HorizontalAlignment = xlCenter
.Range.VerticalAlignment = xlBottom
.Range.WrapText = False
.Range.Orientation = 0
.Range.AddIndent = False
.Range.IndentLevel = 0
.Range.ShrinkToFit = True
.Range.ReadingOrder = xlContext
.Range.MergeCells = False
.Range.Borders(xlDiagonalDown).LineStyle = xlNone
.Range.Borders(xlDiagonalUp).LineStyle = xlNone
With .Range.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Range.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Range.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Range.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
.Range.Borders(xlInsideVertical).LineStyle = xlNone
.Range.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
.Range("A1:K1").Select
With Selection
.Range.Font.Bold = True
.Range.Borders(xlDiagonalDown).LineStyle = xlNone
.Range.Borders(xlDiagonalUp).LineStyle = xlNone
With .Range.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Range.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Range.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Range.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
End With
End With
Set objExcelCI = objExcelW.Charts.Add
With objExcelCI
.ChartType = xlXYScatter
.SetSourceData Source:=Sheets("Sheet1").Range("D57:D66,J57:J66"), _
PlotBy:=xlColumns
.Location Where:=xlLocationAsNewSheet, Name:="Keeling Plot"
.HasTitle = True
.ChartTitle.Characters.Text = "Keeling Plot"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Y-Intercept"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Plot Date"
.HasLegend = False
.PlotArea.Select
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Fill.OneColorGradient Style:=msoGradientDiagonalUp, Variant:=3, _
Degree:=0.231372549019608
With Selection
.Fill.Visible = True
.Fill.ForeColor.SchemeColor = 43
End With
.SeriesCollection(1).Select
With Selection.Border
.ColorIndex = 1
.Weight = xlHairline
.LineStyle = xlDot
End With
With Selection
.MarkerBackgroundColorIndex = 2
.MarkerForegroundColorIndex = 1
.MarkerStyle = xlCircle
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
End With
Set objSheet = Nothing
Set objBook = Nothing
Set objApp = Nothing
Set objExcelCI = Nothing
End Sub
Sample-Output-For-keeling-Plot.xlsPublic Function Corell()
Dim objApp As Excel.Application
Dim objBook As Workbook
Dim objSheet As Worksheet
On Error Resume Next
Set objApp = GetObject("excel.application")
If Err.Number <> 0 Then
Set objApp = CreateObject("excel.application")
End If
Set objBook = objApp.Workbooks.Add
Set objSheet = objApp.Sheets(1)
Dim j As Integer, high As Integer
Dim i As Integer
high = i ' grd_result.Rows - 1
i = 2
For j = 1 To grd_result.Rows - 1
high = i
objSheet.Cells(j, 1).value = grd_result.TextMatrix(j, 2)
objSheet.Cells(j, 2).value = grd_result.TextMatrix(j, 3)
i = i + 1
objSheet.Range("a" & high + 1 & ":a" & high + 1).formula = "=Correl(a1:a" & high & ", b1:b" & high & ")^2"
result = FormatNumber(CDbl(objSheet.Range("a" & high + 1 & ":A" & high + 1).value), 5, vbTrue)
Debug.Print (result)
Next
End If
' objSheet.Range("a" & high + 1 & ":a" & high + 1).formula = "=Correl(a1:a" & high & ", b1:b" & high & ")^2"
' result = FormatNumber(CDbl(objSheet.Range("a" & high + 1 & ":A" & high + 1).value), 5, vbTrue)
'
'MsgBox result
objApp.DisplayAlerts = False
Set objSheet = Nothing
Set objBook = Nothing
objApp.Quit
Set objApp = Nothing
Sub ranger()
Dim startrow As Long
Dim i As Long
Dim n As Long
i = 1
startrow = 2
For n = 1 To 400
Cells(startrow + i, 7).FormulaR1C1 = _
"=RSQ(R" & startrow & "C3:R" & startrow + i & "C3" & ",R" & startrow & "C4:R" & startrow + i & "C4)"
If Cells(startrow + i, 7) < Cells(startrow + i - 1, 7) And i >= 6 And i <= 15 And Cells(startrow + i - 1, 7) > 0.984 Then
' Cells(startrow + i - 1, 7).Font.Bold = True
Cells(startrow + i, 7).ClearContents
startrow = startrow + i
i = 0
End If
i = i + 1
'MsgBox "i = " & i
Next n
End Sub
you have written a lot of text...
Unfortunately it doesn't make it easier to understand your question.
I tried out your code, but it isn't complete: e.g. keeling_Select isn't defined