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
Related
VBA is not finding the matching date in Monthly2. This code is finding all dates that contain 2021 in Sheet1, and pasting them into the correct range, except it is not finding the duplicate date.
Dim ws2 As Worksheet
Set wb = ActiveWorkbook
Set rng1 = wb.Sheets("Sheet1").Range("A1:AD1")
Set rng2 = wb.Sheets("Monthly2").Range("A1:AD1")
Set ws2 = Sheets("Monthly2")
For Each celldate In rng1
CellValue = celldate
If CellValue Like "*2021*" Then
With ThisWorkbook.Sheets("Monthly2")
LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Address
ColumnLetterM = Split(LastColumn, "$")(1)
Set valFound = ThisWorkbook.Sheets("Monthly2").Range("A1:AD1").Cells.Find(CellValue)
End With
If valFound Is Nothing Then
Sheets("Monthly2").Range(ColumnLetterM & "1").Value = celldate
Else
End If
End If
Next celldate
End Sub
Try this:
Sub Monthly2()
Dim celldate As Range
Dim wb As Workbook, v, m
Dim rng1 As Range, rng2 As Range
Set wb = ActiveWorkbook
Set rng1 = wb.Sheets("Sheet1").Range("A1:AD1")
Set rng2 = wb.Sheets("Monthly2").Range("A1:AD1")
For Each celldate In rng1.Cells
v = celldate.Value
If Len(v) > 0 Then
If Year(v) = 2021 Then
m = Application.Match(CLng(v), rng2, 0) 'match in rng2?
If IsError(m) Then
'copy date to next empty cell on row1 on Monthly2
rng2.Parent.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = v
End If
End If
End If
Next celldate
End Sub
I suspect the problem is with date formats. This script logs the result of each comparison so hopefully will identify the problem.
Sub debugging()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, lastcol As Integer
Dim rng1 As Range, rng2 As Range, rngFound As Range
Dim cell1 As Range, cell2 As Range, bFound As Boolean
' log file
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.createtextfile("debug.log")
' rng1
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("Sheet1")
lastcol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng1 = wb.Sheets("Sheet1").Cells(1, 1).Resize(1, lastcol)
' rng2
Set ws2 = wb.Sheets("Monthly2")
lastcol = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng2 = ws2.Range("A1").Resize(1, lastcol)
ts.writeline "rng1 = " & rng1.Address
ts.writeline "rng2 = " & rng2.Address
' compare ws1 to ws2
For Each cell1 In rng1
ts.writeline vbCr & "ws1 " & cell1.Address & " is '" & cell1.Value & "' " & cell1.NumberFormat
If cell1.Value Like "*2021" Then
bFound = False
For Each cell2 In rng2
If cell1 = cell2 Then
ts.writeline " ws2 " & cell2.Address & " '" & cell2.Value & "' = FOUND"
bFound = True
Exit For
Else
ts.writeline " ws2 " & cell2.Address & " '" & cell2.Value & "' <>"
End If
Next
' not found so add column
If bFound = False Then
lastcol = lastcol + 1
ws2.Cells(1, lastcol).Value2 = cell1
Set rng2 = ws2.Range("A1").Resize(1, lastcol)
ts.writeline cell1 & " added rng2 now " & rng2.Address
End If
Else
ts.writeline "SKIPPED Not like *2021*"
End If
Next
ts.Close
MsgBox "See debug.log"
End Sub
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
I have the following code to create copies of a template, populate it based on the data within each row of another worksheet and rename it based on the employee in that row. However, I continue to get a sheet named Template(2).
Option Explicit
Sub NewSheets()
Dim i As Integer
Dim ws As Worksheet
Dim sh As Worksheet
Set ws = Sheets("Template")
Set sh = Sheets("Employee_Data")
Application.ScreenUpdating = True
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = sh.Range("B" & i).Value
ActiveSheet.Range("C1").Value = sh.Range("A" & i).Value
ActiveSheet.Range("C2").Value = sh.Range("G" & i).Value
ActiveSheet.Range("C3").Value = sh.Range("H" & i).Value
ActiveSheet.Range("C4").Value = sh.Range("I" & i).Value
ActiveSheet.Range("C5").Value = sh.Range("J" & i).Value
ActiveSheet.Range("C6").Value = sh.Range("S" & i).Value
ActiveSheet.Range("C7").Value = sh.Range("V" & i).Value
ActiveSheet.Range("C8").Value = sh.Range("W" & i).Value
ActiveSheet.Range("C9").Value = sh.Range("X" & i).Value
ActiveSheet.Range("C11").Value = sh.Range("L" & i).Value
ActiveSheet.Range("C12").Value = sh.Range("AH" & i).Value
ActiveSheet.Range("C13").Value = sh.Range("AJ" & i).Value
ActiveSheet.Range("C14").Value = sh.Range("AM" & i).Value
ActiveSheet.Range("C15").Value = sh.Range("AP" & i).Value
ActiveSheet.Range("C16").Value = sh.Range("AQ" & i).Value
ActiveSheet.Range("H1").Value = sh.Range("F" & i).Value
ActiveSheet.Range("H3").Value = sh.Range("K" & i).Value
ActiveSheet.Range("N1").Value = sh.Range("C" & i).Value
ActiveSheet.Range("N11").Value = sh.Range("N" & i).Value
Next i
End Sub
I did find code which would create the multiple copies of the template and rename them as required but I cannot figure out how to write the code needed to populate the template with the data from each row for the specific employee. That code is as follows:
Sub CreateSheetsFromAList()
' Example Add Worksheets with Unique Names
Dim MyRange As Range
Dim dic As Object, c As Range
Dim k As Variant, tmp As String
Set dic = CreateObject("scripting.dictionary")
Set MyRange = Sheets("Employee_Data").Range("B2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True
For Each c In MyRange
tmp = Trim(c.Value)
If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
Next c
For Each k In dic.keys
If Not WorksheetExists(k) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = k ' renames the new worksheet
End If
Next k
Sheets("Template").Visible = False
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
I know I can always delete the extra worksheet but it would be nice if I didn't have too do that as the current project has 13 different groups for this will need to be completed. Any help would be greatly appreciated.
Better to be a little more explicit, and reduce/remove reliance on ActiveSheet:
Option Explicit
Sub NewSheets()
Dim i As Integer
Dim ws As Worksheet, wb As Workbook
Dim sh As Worksheet, wsCopy as worksheet, v
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Template")
Set sh = wb.Sheets("Employee_Data")
For i = 2 To sh.Range("B" & sh.Rows.Count).End(xlUp).Row
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set wsCopy = wb.Sheets(wb.Sheets.Count) '<<<< get a reference to the copy
wsCopy.Name = sh.Range("B" & i).Value
wsCopy.Range("C1").Value = sh.Range("A" & i).Value
'EDIT: only copy value if not empty
v = sh.Range("AJ" & i).Value
If Len(v) > 0 Then wsCopy.Range("C13").Value = v
'...
'snipped for clarity
'...
wsCopy.Range("N11").Value = sh.Range("N" & i).Value
Next i
End Sub
The code below executes but the:
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
lastcell = .Range("B" & i).Value
End If
End If
Next i
Does not seem to be doing what I have intended. What I intended was that if the cell A & i's value = lets say rng1, if that is true then move on to the next parameter and check if that i's C column cell = rng2 if that is correct then take that row i's B column and set cell "C3" on the proof tab equal to B & i's value. Then move on to the next i; if it finds another B that fit the two conditions above, then set cell c3.offset(1) = to that i's value. This unfortunately is not working for me. ANyone have any suggestions :)
This is what it looks like when I run the code:
Sub Extract_Bank_Amount()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, lastcell As Range
Dim lRow As Long, i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Bank Statement")
Set rng1 = wb.Sheets("Payroll Journal").Range("B1")
Set rng2 = wb.Sheets("Payroll Journal").Range("B3")
Set lastcell = wb.Sheets("Proof").Range("C3" & Rows.Count).End(xlUp).Offset(1)
wb.Sheets("Bank Statement").Activate
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
lastcell = .Range("B" & i).Value
End If
End If
Next i
End With
End Sub
You need to find the next empty cell each time you add a value to the end of the list.
Sub Extract_Bank_Amount()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, lastcell As Range
Dim lRow As Long, i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Bank Statement")
Set rng1 = wb.Sheets("Payroll Journal").Range("B1")
Set rng2 = wb.Sheets("Payroll Journal").Range("B3")
wb.Sheets("Bank Statement").Activate
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
With wb.Sheets("Proof")
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = .Range("B" & i).Value
End With
End If
End If
Next i
End With
End Sub
I would give the ranges on "Payroll Journal" meaningful names then used their Defined Names to refer to them.
wb.Sheets("Payroll Journal").Range("B1").Name = "PayrollB1"
wb.Sheets("Payroll Journal").Range("B3").Name = "PayrollB3"
This will allow you to get rid of a lot of the fluff.
Sub Extract_Bank_Amount2()
Dim cell As Range
With Worksheets("Bank Statement")
For Each cell In .Range("B" & .Rows.Count).End(xlUp)
If cell.Offset(0, -1).Value = Range("PayrollB1").Value Then
If cell.Offset(0, 1).Value = Range("PayrollB3").Value Then
With wb.Sheets("Proof")
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = cell.Value
End With
End If
End If
Next
End With
End Sub
You should also download Rubberduck. Rubberduck is a COM add-in for the VBA IDE that will help you debug and optimise your code. Most importantly for me it saves me a ton of time by formatting my code for me.
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