I have the following code and I am getting "identifier under cursor not recognized" on all portions within the For loop.
Sub Finalize_Macro()
'
' Finalize all data on the Offer Data worksheet
'
Dim DSheet As Worksheet
Dim PSheet As Worksheet
Dim LastRow As Long
Dim ValCol As Long
Dim DayCol As Long
Dim i As Integer
Set DSheet = Worksheets("Offer Data")
Set PSheet = Worksheets("PivotTable")
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
ValCol = PSheet.Cells(2, Columns.Count).End(xlToLeft).Column - 1
DayCol = PSheet.Cells(2, Columns.Count).End(xlToLeft).Column
DSheet.Select
[E1:I1] = [{"Redemption Value", "Redemption Days", "Theo", "Actual", "Rated Days"}]
For i = 2 To LastRow
Cells(i, 5).Formula = "=IFERROR(XLOOKUP(A" & i & ",PivotTable!(A:A),PivotTable!.Columns(" & ValCol & ")),0)"
Cells(i, 6).Formula = "=IFERROR(XLOOKUP(A" & i & ",PivotTable!(A:A),PivotTable!.Columns(" & DayCol & ")),0)"
Cells(i, 7).Formula = "=IFERROR(XLOOKUP(A" & i & ",'Big Query Data'!(B:B),'Big Query Data'!(C:C)),0)"
Cells(i, 8).Formula = "=IFERROR(XLOOKUP(A" & i & ",'Big Query Data'!(B:B),'Big Query Data'!(D:D)),0)"
Cells(i, 9).Formula = "=IFERROR(XLOOKUP(A" & i & ",'Big Query Data'!(B:B),'Big Query Data'!(E:E)),0)"
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
If anyone could help advise why this isn't working, I'd greatly appreciate it!
This is what I ended up using - thanks to ScottCraner & BigBen for the assistance!
Sub Finalize_Macro()
'
' Finalize all data on the Offer Data worksheet
'
Dim DSheet As Worksheet
Dim PSheet As Worksheet
Dim LastRow As Long
Dim ValCol As Long
Dim DayCol As Long
Dim i As Integer
Set DSheet = Worksheets("Offer Data")
Set PSheet = Worksheets("PivotTable")
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
ValCol = PSheet.Cells(2, Columns.Count).End(xlToLeft).Column - 1
DayCol = PSheet.Cells(2, Columns.Count).End(xlToLeft).Column
DSheet.Select
[E1:I1] = [{"Redemption Value", "Redemption Days", "Theo", "Actual", "Rated Days"}]
Range("E2:E" & LastRow).Formula2 = "=IFERROR(XLOOKUP($A2,PivotTable!$A:$A,PivotTable!" & PSheet.Columns(ValCol).Address & "),0)"
Range("F2:F" & LastRow).Formula2 = "=IFERROR(XLOOKUP($A2,PivotTable!$A:$A,PivotTable!" & PSheet.Columns(ValCol).Address & "),0)"
Range("G2:G" & LastRow).Formula2 = "=IFERROR(XLOOKUP($A2,'Big Query Data'!$B:$B,'Big Query Data'!$C:$C),0)"
Range("H2:H" & LastRow).Formula2 = "=IFERROR(XLOOKUP($A2,'Big Query Data'!$B:$B,'Big Query Data'!$D:$D),0)"
Range("I2:I" & LastRow).Formula2 = "=IFERROR(XLOOKUP($A2,'Big Query Data'!$B:$B,'Big Query Data'!$E:$E),0)"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Related
I'm trying to get my spreadsheet to automatically generate new names and sheets based on a data dump. I currently have the sheet working so that it will generate the name and sheet for each row of data, but I cannot get it to populate the sheet using that row.
There is a specific section of code that I cannot get to work:
For Each Nm In shNAMES
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm) ' <<< This line here
End If
Next Nm
I know that the issue is using Nm to reference the cell (it's returning "OP01" which is the cell contents), but I'm trying to not add another workaround. I've tried using other functions to do similar after the Nm loop has finished, but can't seem to get those working either. Surely the answer has to be simple and I'm just missing something?
Option Explicit
Sub SheetsFromTemplate()
Application.ScreenUpdating = False
Rows("1:8").EntireRow.Delete
Call CreateLONums
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long
With ThisWorkbook
Set wsTEMP = .Sheets("Template")
wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
Set wsMASTER = .Sheets("Creation Page")
Set wsINDEX = .Sheets("Local Options")
With Sheets("Creation Page").Columns("A")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
End With
Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
For Each Nm In shNAMES
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm)
End If
Next Nm
wsINDEX.Activate
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden
End With
Worksheets("Creation Page").Delete
Worksheets("Template").Delete
Call CreateLinksToAllSheets
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub CreateLONums()
Dim firstrow As Long, lastrow As Long, rowcount As Integer
Columns("A:A").Insert Shift:=xlToRight
With Sheets("Creation Page").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
For rowcount = firstrow To firstrow + 9
Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
Next rowcount
For rowcount = firstrow + 9 To lastrow
Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
Next rowcount
End With
End Sub
Appreciate any insight available.
Managed to work it out, took way longer than it should have -.-'
I borrowed a bit of Function code to reference the number from column A, then used that to reference the cells that I wanted.
For Each Nm In shNAMES
rownum = GetDigits(Nm) 'This bit here is calling the function
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value `This is utilising rownum to reference the cells
End If
Next Nm
Function code can be found here: How to find numbers from a string?
Entire code section in case it is useful to someone in future:
Option Explicit
Sub SheetsFromTemplate()
Application.ScreenUpdating = False
Rows("1:8").EntireRow.Delete
Call CreateLONums
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long, rownum As Integer
With ThisWorkbook
Set wsTEMP = .Sheets("Template")
wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
Set wsMASTER = .Sheets("Creation Page")
Set wsINDEX = .Sheets("Local Options")
With Sheets("Creation Page").Columns("A")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Available"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
End With
Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
For Each Nm In shNAMES
rownum = GetDigits(Nm)
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value
End If
Next Nm
wsINDEX.Activate
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden
End With
Worksheets("Template").Move after:=Worksheets(Worksheets.Count)
Worksheets("Creation Page").Move after:=Worksheets(Worksheets.Count)
Call CreateLinksToAllSheets
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub CreateLONums()
Dim firstrow As Long, lastrow As Long, rowcount As Integer
Columns("A:A").Insert Shift:=xlToRight
With Sheets("Creation Page").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
For rowcount = firstrow To firstrow + 9
Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
Next rowcount
For rowcount = firstrow + 9 To lastrow
Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
Next rowcount
End With
End Sub
Sub CreateLinksToAllSheets()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 1).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name
ActiveCell.Offset(1, 0).Select
End If
Next sh
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription
End Sub
Sub UpdateIndexTechSpec()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 2).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Value = sh.Range("B2").Value
ActiveCell.Offset(1, 0).Select
End If
Next sh
End Sub
Sub UpdateIndexOptDescription()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 3).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Value = sh.Range("D2").Value
ActiveCell.Offset(1, 0).Select
End If
Next sh
End Sub
Function GetDigits(ByVal s As String) As String
Dim char As String
Dim i As Integer
GetDigits = ""
For i = 1 To Len(s)
char = Mid(s, i, 1)
If char >= "0" And char <= "9" Then
GetDigits = GetDigits + char
End If
Next i
End Function
My error comes at the definition of LR. It is error object required 424. Anyone knows the problem?
Sub
Dim LR As Long
Dim FLR As Long
LR = wb.Sheets("DTH&TPD Claims List").Cells(Row.Count, 2).End(xlUp).Row
FLR = wb.Sheets("DTH&TPD Claims List").Cells(Row.Count, 1).End(xlUp).Row + 1
wb.Sheets("DTH&TPD Claims List").Cells(FLR, 1).Value = "19"
wb.Sheets("DTH&TPD Claims List").Cells(FLR, 1).Select
Selection.AutoFill Destination:=Range("A" & FLR & ":" & "A" & LR)
End Sub
After Rectification:
There is Error in Selection.Autofill in the Below code now.
Sub tst()
Dim LR As Long
Dim FLR As Long
Dim wb As Workbook
Set wb = ActiveWorkbook 'assuming you want your code to run in
With wb.Sheets("DTH&TPD Claims List")
LR = .Cells(.Rows.Count, 2).End(xlUp).row
FLR = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Cells(FLR, 1).Value = "19"
.Cells(FLR, 1).Select
Msgbox LR & " " & FLR
Selection.AutoFill Destination:=.Range("A" & FLR & ":A" & LR)
End With
End Sub
Problems:
No declaration of wb
Wrong formula row.count
Try this:
Sub tst()
Dim LR As Long
Dim FLR As Long
Dim wb As Workbook
Set wb = ActiveWorkbook 'assuming you want your code to run in
With wb.Sheets("DTH&TPD Claims List")
LR = .Cells(.Rows.Count, 2).End(xlUp).row
FLR = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Cells(FLR, 1).Value = "19"
.Cells(FLR, 1).Select
Msgbox LR & " " & FLR
Selection.AutoFill Destination:=.Range("A" & FLR & ":A" & LR)
End With
End Sub
I have cleaned up your code as well.
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
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
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