Excel VBA Script to dynamically add series to chart - excel

I'm trying to dynamically add multiple series to a line chart. I don't know beforehand how many series there are so it needs to be dynamic. What I've come up with but doesn't work is the following:
The sheet ActiveSheet (or Sheets("Data")) has Rows from C14 until Cend containing the XValues and Columns from E14:Eend until R14:Rend where "end" marks the last row of data as determined by column C. The series names are stored in row 9. XValues are the same for all series.
My big problem is, that I can't find a way to dynamically add all the data columns as series to my chart together with the respective name. I'm not an expert in VBA so please be kind. I already read various sources and tried many scripts, none seem to work. The Object Catalogue was a bit of a help, however my problem persists.
Sub MakeChart()
Dim LastColumn As Long
Dim LastRow As Long
Dim i As Integer
Dim u As Integer
Dim NameRng As String
Dim CountsRng As Range
Dim xRng As Range
LastColumn = ActiveSheet.Cells(8, Columns.Count).End(xlToLeft).Column
ColumnCount = LastColumn - 4
LastRow = ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
' Debug.Print ("Last Column: " & LastColumn & " Count: " & ColumnCount & " LastRow: " & LastRow)
Charts.Add
With ActiveChart
.ChartType = xlLineMarkers
.HasTitle = True
.ChartTitle.Text = "Test"
End With
For i = 1 To ColumnCount
u = i + 4
NameRng = Sheets("Data").Range("R9:C" & u).Value
Set xRng = Sheets("Data").Range("R14:C3", "R" & LastRow & ":C3")
Set CountsRng = Sheets("Data").Range("R14:C" & u, "R" & LastRow & ":C" & u)
' Debug.Print ("CountsRng: R14:C" & u & ", R" & LastRow & ":C" & u & " NameRng: " & NameRng & " xRng: R14:C3 , R" & LastRow & ":C3")
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(i).XValues = xRng
ActiveChart.SeriesCollection(i).Values = CountsRng
ActiveChart.SeriesCollection(i).Name = NameRng
Next i
End Sub

thanks for the help. I solved the problem. It seems as I have somehow completely messed up the notation of the cell range. You cannot use
Set xRng = Sheets("Data").Range("R14:C3", "R" & LastRow & ":C3")
But rather have to use
Set xRng = .Range(.Cells(14, 3), .Cells(LastRow, 3))
Also, the use of Charts.Add didnt help very much as Excel tries to automatically find the correct ranges for all series and adds them resulting in a completely messed up chart. A better way was to use
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=20, Width:=800, Top:=20, Height:=500)
As this will create a completely empty graph to which you can add your own series
Here is the complete and working code for anyone interested:
Sub MakeChart()
Dim LastRow As Long
Dim LastColumn As Long
Dim ColumnCount As Long
LastRow = ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
LastColumn = ActiveSheet.Cells(8, Columns.Count).End(xlToLeft).Column
ColumnCount = LastColumn - 4
Debug.Print ("Last Column: " & LastColumn & " Count: " & ColumnCount & " LastRow: " & LastRow)
Dim wsChart As Worksheet
Set wsChart = Sheets(1)
wsChart.Activate
Dim ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=20, Width:=800, Top:=20, Height:=500)
ChartObj.chart.ChartType = xlLineMarkers
Dim i As Integer
Dim u As Integer
Dim NameRng As String
Dim xRng As Range
Dim CountsRng As Range
For i = 1 To ColumnCount
u = i + 4
With Sheets("Data")
NameRng = .Cells(9, u).Value
Set CountsRng = .Range(.Cells(14, u), .Cells(LastRow, u))
Set xRng = .Range(.Cells(14, 3), .Cells(LastRow, 3))
Debug.Print "--" & i & "--" & u & "--"
Debug.Print "x Range: " & xRng.Address
Debug.Print "Name Range: " & .Cells(9, u).Address
Debug.Print "Value Range: " & CountsRng.Address
End With
'Set ChartSeries = ChartObj.chart.SeriesCollection.NewSeries
'With ActiveChart.SeriesCollection.NewSeries
With ChartObj.chart.SeriesCollection.NewSeries
.XValues = xRng
.Values = CountsRng
.Name = NameRng
End With
'Set xRng = Nothing
'Set CountsRng = Nothing
'NameRng = ""
Next i
'ChartObj.Activate
With ChartObj.chart
.SetElement (msoElementLegendBottom)
.Axes(xlValue).MajorUnit = 1
.Axes(xlValue).MinorUnit = 0.5
.Axes(xlValue).MinorTickMark = xlOutside
'.Axes(xlCategory).TickLabels.NumberFormat = "#,##000"
.Axes(xlCategory).TickLabels.NumberFormat = "#,##0"
'.Location Where:=xlLocationAsObject, Name:="Plot"
End With
End Sub

sample code
Sub InsertChart()
Dim first As Long, last As Long
first = 10
last = 20
Dim wsChart As Worksheet
Set wsChart = Sheets(1)
wsChart.Activate
wsChart.Shapes.AddChart.Select
Dim chart As chart
Set chart = ActiveChart
chart.ChartType = xlXYScatter
' adding series
chart.SeriesCollection.NewSeries
chart.SeriesCollection(1).Name = "series name"
chart.SeriesCollection(1).XValues = "=" & ActiveSheet.Name & "!$A$" & first & ":$A$" & last
chart.SeriesCollection(1).Values = "=" & ActiveSheet.Name & "!$B$" & first & ":$B$" & last
End Sub
you can iterate over range and keep adding more series

Related

Xlookup with multiple criteria in VBA

I feel like this is something stupidly simple, but I've been Googling and experimenting for a while and seem to be coming up empty handed guess is I'm searching the wrong term/word. Anyway, let me explain.
for Example :
this code: Run -Time error '13' Type mismatch
Dim ws, sh As Worksheet
Set ws = Worksheets("Sheet1")
Set sh = Worksheets("Sheet2")
Dim Ctr1, Ctr2, Result As Range
Set Ctr1 = ws.Range("A2:A100")
Set Ctr2 = ws.Range("B2:B100")
Set Result = ws.Range("C2:C100")
With sh
.Cells(2, 7).Value = WorksheetFunction.XLookup( _
.Cells(2, 5) & .Cells(2, 6), Ctr1 & Ctr2, Result, 0)
End With
End Sub
Create the XLOOKUP parameters from the range addresses.
Sub Macro1()
Dim ws As Worksheet, sh As Worksheet
Set ws = Worksheets("Sheet1")
Dim Ctr1, Ctr2, Result As Range
Set Ctr1 = ws.Range("A2:A100")
Set Ctr2 = ws.Range("B2:B100")
Set Result = ws.Range("C2:C100")
' XLOOKUP parameters
Dim p(3) As String, i As Long, w As String
w = "'" & ws.Name & "'!"
p(1) = w & Ctr1.Address(0, 0) & "&" & _
w & Ctr2.Address(0, 0)
p(2) = w & Result.Address(0, 0)
p(3) = 0
Set sh = Worksheets("Sheet2")
With sh
For i = 2 To 2
p(0) = .Cells(i, 5).Address(0, 0) & "&" & .Cells(i, 6).Address(0, 0)
.Cells(i, 7).Formula = "=XLOOKUP(" & Join(p, ",") & ")"
Next
End With
End Sub

Selecting a Excel sheet based on number

I'm new to macros and VBA in Excel. Is there a way to check if the Testvalue is between Value 1 and Value 2, and move to the corresponding sheet? And if it's not, move to the next row and repeat.
E.g.
With the testvalue 3742 sheet A21 should be selected.
Simply iterate over each row until required condition is met:
Dim testVal As Long, r As Integer
Dim yourSheet As Worksheet
Set yourSheet = Sheet1
With yourSheet
testVal = .Range("E2").Value
r = 2
Do Until (.Range("A" & r).Value <= testVal) And _
(.Range("B" & r).Value >= testVal)
ThisWorkbook.Worksheets(.Range("C" & r).Value).Activate
r = r + 1
Loop
End With
In my opinion, instead of looping each row is faster if you use Find method.
Sub test()
Dim rngSearchA As Range, rngSearchB As Range, rngFoundA As Range, rngFoundB As Range
Dim strValue As String, strSheetName As String
Dim LastRowA As Long, LastRowB As Long
With ThisWorkbook.Worksheets("Sheet1")
strValue = .Range("E2").Value
strSheetName = ""
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rngSearchA = .Range("A2:A" & LastRowA)
Set rngSearchB = .Range("B2:B" & LastRowB)
Set rngFoundA = rngSearchA.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
Set rngFoundB = rngSearchB.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
If Not rngFoundA Is Nothing And Not rngFoundB Is Nothing Then
If .Range("C" & rngFoundA.Row).Value <> .Range("C" & rngFoundB.Row).Value Then
MsgBox "Searching value appears in both columns with different Sheet name."
Else
strSheetName = .Range("C" & rngFoundA.Row).Value
End If
ElseIf Not rngFoundA Is Nothing Or Not rngFoundB Is Nothing Then
If Not rngFoundA Is Nothing Then
strSheetName = .Range("C" & rngFoundA.Row).Value
Else
strSheetName = .Range("C" & rngFoundB.Row).Value
End If
Else
MsgBox "Value not found!"
End If
If strSheetName <> "" Then
ThisWorkbook.Worksheets(strSheetName).Activate
End If
End With
End Sub

In SrchRng, If Cell Contains Data, Paste Formula To The Right

I'm working on a VBA function in Access to output a spreadsheet. Unfortunately, I'm not finding any resources online that can help with what I would like to do.
My information is output in columns ("A2:AF" & Lrow). "Lrow" defines the last row of the information. "Lrow +1" is where I have a formula totaling everything in each column.
I'd like to search ("C2:AF" & Lrow) for cells that <> "" and paste a formula (Offset 0,1) to divide that cell by the total in "Lrow +1". For example, in my picture, there is data (225.060) in C4. I am trying to paste a formula in D4 to divide C4 by C11 (or Lrow +1 since Lrow changes each time I output a spreadsheet)
Here is the code I have so far, but I'm stuck on the formula part:
Dim SrchRng As Range, Cel As Range
Dim wks As Excel.Worksheet
Set SrchRng = wks.Cells("C2:AF" & Lrow)
For Each Cel In SrchRng
If Cel.Value <> "" Then
Cel.Offset(0,1).Value = "=Cel.Value/(???)"
Tim Williams suggested I add my entire code because I'm getting an error with the first line of his answer. I get Error5: Invalid procedure call or argument.
Private Sub Command19_Click()
'Export to Excel
Dim rs1 As DAO.Recordset, rs2 As DAO.Recordset, rs3 As DAO.Recordset, rs4
As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim cnt As Integer
Dim SrchRng As Range, Cel As Range
Dim Lrow As Long, Lrow1 As Long
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng, rng1 As Excel.Range
Set db = CurrentDb
Set appExcel = Excel.Application
Set wbk = appExcel.Workbooks.Add
Set wks = wbk.Worksheets(1)
Set rng = wks.Range("A2")
appExcel.Visible = False
cnt = 1
Set qdf = CurrentDb.QueryDefs("qry_Comparison_Bulk")
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next
Set rs1 = qdf.OpenRecordset()
For Each fld In rs1.Fields
wks.Cells(1, cnt).Value = fld.Name
cnt = cnt + 1
Next fld
Call rng.CopyFromRecordset(rs1, 4000, 26)
qdf.Close
rs1.Close
Set rs1 = Nothing
Set qdf = Nothing
For Colx = 4 To 26 Step 2
Columns(Colx).Insert Shift:=xlToRight
Next
Set SrchRng = wks.Cells("C2:AF" & Lrow)
For Each Cel In SrchRng
If Cel.Value <> "" Then
Cel.Offset(0, 1).Formula = "=" & Cel.Address & "/" & wks.Cells(Lrow +1, Cell.Column).Address
End If
Next
'Identifies the last row and row beneath it
Lrow = wks.Cells(Rows.Count, "A").End(xlUp).Row
Lrow1 = wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
'Everything below is formatting
With wks.Range("A" & Lrow1, "AF" & Lrow1)
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 16
.HorizontalAlignment = xlRight
End With
With wks.Range("C2:AE" & Lrow)
.NumberFormat = "0.000"
End With
wks.Cells(Lrow1, "C").Formula = "=SUM(C2:C" & Lrow & ")"
wks.Cells(Lrow1, "E").Formula = "=SUM(E2:E" & Lrow & ")"
wks.Cells(Lrow1, "G").Formula = "=SUM(G2:G" & Lrow & ")"
wks.Cells(Lrow1, "I").Formula = "=SUM(I2:I" & Lrow & ")"
wks.Cells(Lrow1, "K").Formula = "=SUM(K2:K" & Lrow & ")"
wks.Cells(Lrow1, "M").Formula = "=SUM(M2:M" & Lrow & ")"
wks.Cells(Lrow1, "O").Formula = "=SUM(O2:O" & Lrow & ")"
wks.Cells(Lrow1, "Q").Formula = "=SUM(Q2:Q" & Lrow & ")"
wks.Cells(Lrow1, "S").Formula = "=SUM(S2:S" & Lrow & ")"
wks.Cells(Lrow1, "U").Formula = "=SUM(U2:U" & Lrow & ")"
wks.Cells(Lrow1, "W").Formula = "=SUM(W2:W" & Lrow & ")"
wks.Cells(Lrow1, "Y").Formula = "=SUM(Y2:Y" & Lrow & ")"
wks.Cells(Lrow1, "AA").Formula = "=SUM(AA2:AA" & Lrow & ")"
wks.Cells(Lrow1, "AC").Formula = "=SUM(AC2:AC" & Lrow & ")"
wks.Cells(Lrow1, "AE").Formula = "=SUM(AE2:AE" & Lrow & ")"
wks.Cells(Lrow1, "B").Formula = "TOTAL (MG)"
With wks.Range("A1:AF1")
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 16
.NumberFormat = "#"
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
appExcel.Visible = True
End Sub
enter code here
You need to set the Formula property, and the formula needs to be parseable
Something like this:
Dim SrchRng As Range, Cel As Range
Dim wks As Excel.Worksheet
Set SrchRng = wks.Range("C2:AF" & Lrow).Cells 'edit: "Cells()" >> "Range()"
For Each Cel In SrchRng
If Cel.Value <> "" Then
Cel.Offset(0,1).Formula = _
"=" & Cel.Address & "/" & wks.Cells(Lrow +1, Cel.Column).address

How to copy and paste whole columns of data from different worksheets in Excel VBA

I'm currently working on a script that is supposed to copy four columns of data from one worksheet and paste over them to another worksheet in the same workbook. Noted I only need the data from row two onwards, I have tried with column() and Range() but it doesn't seem to be working.
Below are the script which only copies one cell on second row and paste over to another cell in the target worksheet.
Sub Sample()
Dim lastRow As Long, i As Long
Dim CopyRange As Range
Dim rw As Range
Dim rw1 As Range
Dim rw2 As Range
Dim rw3 As Range
Dim des As Range
Dim des1 As Range
Dim des2 As Range
Dim des3 As Range
'~~> Change Sheet1 to relevant sheet name
With Sheets(1)
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
If CopyRange Is Nothing Then
Set CopyRange = .Rows(i)
Else
Set CopyRange = Union(CopyRange, .Rows(i))
Set rw = Range("P2")
Set rw1 = Range("W2")
Set rw2 = Range("C2")
Set rw3 = Range("R2")
End If
End If
Next
If Not CopyRange Is Nothing Then
Set des = Sheets(3).Range("P2")
Set des1 = Sheets(3).Range("R2")
Set des2 = Sheets(3).Range("T2")
Set des3 = Sheets(3).Range("U2")
'~~> Change Sheet2 to relevant sheet name
rw.Copy des
rw1.Copy des1
rw2.Copy des2
rw3.Copy des3
Application.CutCopyMode = False
End If
End With
End Sub
hope this helps
'// code example copies the Column A on Sheet1 into Column A2 on Sheet2.
Sub CopyFourColumns()
'// Declare your variables.
Dim wSheet1 As Worksheet
Dim wSheet2 As Worksheet
Dim wSlastRow As Long
Dim X As Long
Dim RngToCopy As Range
Dim RngToPaste As Range
'// Set here Workbook(Sheets) names
With ThisWorkbook
Set wSheet1 = Sheets("Sheet1")
Set wSheet2 = Sheets("Sheet2")
End With
'// Here lets Find the last row of data
wSlastRow = wSheet1.Range("A" & Rows.Count).End(xlUp).Row
wSlastRow = wSheet1.Range("B" & Rows.Count).End(xlUp).Row
wSlastRow = wSheet1.Range("C" & Rows.Count).End(xlUp).Row
wSlastRow = wSheet1.Range("D" & Rows.Count).End(xlUp).Row
'// Now Loop through each row
For x = 1 To wSlastRow
Set RngToPaste = wSheet2.Range("A" & (x + 1))
With wSheet1
Set RngToCopy = Union(.Range("A" & x), .Range("A" & x))
RngToCopy.copy RngToPaste
Set RngToPaste = wSheet2.Range("B" & (x + 1))
Set RngToCopy = Union(.Range("B" & x), .Range("B" & x))
RngToCopy.copy RngToPaste
Set RngToPaste = wSheet2.Range("C" & (x + 1))
Set RngToCopy = Union(.Range("C" & x), .Range("C" & x))
RngToCopy.copy RngToPaste
Set RngToPaste = wSheet2.Range("D" & (x + 1))
Set RngToCopy = Union(.Range("D" & x), .Range("D" & x))
RngToCopy.copy RngToPaste
End With
Next X
'// Simple Msg Box
MsgBox "Copy & Paste is Done."
End Sub

macro to create multiple sub totals in one column

Can anyone help me with this macro to create multiple sub totals in one column? Any help would be great. I have a group of numbers in column Y. which begins at row 16.
The data is listed on every three lines until the end of that section then there is a gap of around thirty lines then it beings again. I want to create a macro to count how many numbers >45 in each section. Put the total 2 rows below the last data point of each section. In column X on the same row place Number>45
Sub Sample()
Dim result As Long, firstrow As Long, lastrow As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Lastrow in Col Y
lastrow = .Range("Y" & .Rows.Count).End(xlUp).Row
'~~> Set First row
firstrow = 16
'~~> Set your range
Set rng = .Range("Y" & firstrow & ":Y" & lastrow)
'~~> Put relevant values
.Range("x" & lastrow + 2).Value = "Total>45"
.Range("y" & lastrow + 2).Value = _
Application.WorksheetFunction.CountIf(rng, ">45")
End With
End Sub
try the below procedure
and loop backwards to ROW=1 like this:
Sub setTotals()
Dim iRow As Integer
Dim iLastRow As Integer
Dim sFormulaTargetAddress As String
iLastRow = ActiveSheet.Range("Y" & ActiveSheet.Rows.Count).End(xlUp).Row
iRow = iLastRow
Do Until iRow = 1
If Range("Y" & iRow).Value <> "" Then
'
' define the section
sFormulaTargetAddress = "Y" & Range("Y" & iRow).End(xlUp).Row & ":Y" & iRow & ""
'
' Put in the COUNTIF > 45 of the current section...
'
Range("Y" & iRow + 2).Formula = "=COUNTIF(" & sFormulaTargetAddress & ","">45"")"
' '
'Range("X" & iRow + 2).Formula = "=COUNTIF(" & sFormulaTargetAddress & ","">45"")"
Range("X" & iRow + 2).value="Numbers > 45"
'
' find the next section
iRow = Range("Y" & iRow).End(xlUp).Row
If Range("Y" & iRow) <> "" Then iRow = Range("Y" & iRow).End(xlUp).Row
Else
iRow = Range("Y" & iRow).End(xlUp).Row
End If
Loop
End Sub
HTH
Philip

Resources