With the snippet below I am trying to iteratively add new series to a chart. When execution reaches the third line in the loop (updating the name property) I get an "Object required" error. Reading the docs, I think it might be something to do with the .Name property being read-only for embedded charts but I don't know. Can someone show me where I am going wrong and how I can update the name of a series in a chart inside a for loop?
With Application.ActiveSheet
.Shapes.AddChart2(240, xlLine, 600, 20, 300, 300).Select
For lngB = 2 To 6
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(lngB).Values = _
.Range(.Cells(2, lngB).Address & ":" & .Cells(10, lngB).Address)
ActiveChart.SeriesCollection(lngB).XValues = _
.Range(.Cells(2, 1).Address & ":" & .Cells(10, 1).Address)
AciveChart.SeriesCollection(lngB).name = .Cells(1, lngB).Value
Next lngB
End With
Please, test the next updated code. Each NewSeries receives a number in the creation order. So, SeriesCollection(lngB), where lngB is 2, does not exist yet, since only such a series have been created. So the series number must start with 1, even if the iteration starts from 2:
Sub testMakeChartNameSeries()
Dim lngB As Long
With ActiveSheet
.Shapes.AddChart2(240, xlLine, 600, 20, 300, 300).Select
For lngB = 2 To 6
ActiveChart.SeriesCollection.NewSeries.Values = _
.Range(.cells(2, lngB).Address & ":" & .cells(10, lngB).Address)
ActiveChart.SeriesCollection(lngB - 1).XValues = _
.Range(.cells(2, 1).Address & ":" & .cells(10, 1).Address)
ActiveChart.SeriesCollection(lngB - 1).Name = .cells(1, lngB).value
Next lngB
End With
End Sub
Related
I have this piece of code
Sub neviem()
Dim ws As Worksheet
Dim i As Range
Dim j As Long
Set i = Range("GKC")
For j = i.Rows.Count To 1 Step -1
If IsEmpty(Range("E3").Value) Then
If i(j, 1) Like Range("E2") Then
i(j, 1).Offset(0, 1).Copy Range("E2").Offset(1, 0)
End If
ElseIf i(j, 1) Like Range("E2") Then
i(j, 1).Offset(0, 1).Copy Range("E2").Offset(1, 0) & "," & Range("E2").Value
End If
Next
End Sub
With this code I'm trying to add multiple text values in the same cell. The first part is ok when I run it, it will add a text value. The problem is when I run it for a second time it gives me an error
runtime err 1004 copy method class failed
so I'm not able to put more text values next to the one I already have.
Is this possible in VBA?
Instead this i(j, 1).Offset(0, 1).Copy Range("E2").Offset(1, 0) & "," & Range("E2").Value
Try this i(j, 1).Offset(0, 1) = Range("E3") & "," & Range("E2")
I've been strugling to color alternate rows in a range in VBA. The problem is that the Range method seems not to select the proper range and I end up coloring adjacent cells. This is my desired output:
But, this is what I actually get:
This is the code I created:
Sub limpar_aniversariantes()
Worksheets("Aniversariantes").Range("B4:D900").ClearContents
'Worksheets("Aniversariantes").Range("B4:D900").Interior.Color = RGB(255, 255, 255)
End Sub
Sub gerar_lista_aniversariantes()
limpar_aniversariantes
Dim newrange As Range, rw As Range
Sheets("Base de Alunos").Select
Set newrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
CountInicioMes = 12
CountInicio = 16
Count = CountInicio
count_first_line = 0
For Each rw In newrange.Rows
Worksheets("Aniversariantes").Range("B" & Count).Value = rw.Cells(2).Value
Worksheets("Aniversariantes").Range("C" & Count).Value = Left(rw.Cells(5).Value, 2)
Worksheets("Aniversariantes").Range("C" & Count).NumberFormat = "DD"
Worksheets("Aniversariantes").Range("D" & Count).Value = UCase(rw.Cells(15).Value)
'Worksheets("Aniversariantes").Range("A" & Count).Value = Count
'pintar linhas alternadamente de cinza
If Count Mod 2 = 0 Then
Worksheets("Aniversariantes").Range("B" & Count & ":D" & Count).Interior.Color = RGB(211, 211, 211)
Debug.Print ("B" & Count & ":D" & Count)
End If
'pegar mes dos aniversariantes, eh preciso pular header
If count_first_line < 2 Then
count_first_line = count_first_line + 1
If count_first_line = 2 Then
my_date = rw.Cells(5).Value
End If
End If
'Debug.Print Left(rw.Cells(5).Value, 2)
Count = Count + 1
'Debug.Print rw.Cells(2).Value
Next rw
Worksheets("Aniversariantes").Range("B" & (CountInicio + 1) & ":D" & Count).Sort key1:=Worksheets("Aniversariantes").Range("C" & (CountInicio + 1) & ":C" & Count), _
Header:=xlNo
'limpar bordas anteriores
Worksheets("Aniversariantes").Columns("B:D").Borders.LineStyle = xlNone
Worksheets("Aniversariantes").Range("B" & (CountInicio) & ":D" & (Count - 1)).Borders.LineStyle = xlContinuous
'.Weight = xlThin.ColorIndex = 3
my_month = Mid(my_date, 4, 2)
my_month_written = RetornarMes(CInt(my_month))
Worksheets("Aniversariantes").Range("B" & CountInicioMes).Value = UCase(my_month_written)
Worksheets("Aniversariantes").Range("B" & CountInicio).Value = "NOME"
Worksheets("Aniversariantes").Range("C" & CountInicio).Value = "DIA"
Worksheets("Aniversariantes").Range("D" & CountInicio).Value = "MODALIDADE"
'mudar cor de fundo
'Worksheets("Aniversariantes").Range("B" & CountInicio & ":D" & CountInicio).Interior.Color = RGB(255, 255, 0)
'Debug.Print my_month_written
End Sub
I am coping values from one worksheet to another and I am using MOD function to only color even lines. Everytime I copy these values the number of lines can change, that's why I need to do it by VBA. I am not mastered in VBA so any help is appreciated. I have struggled to do it the whole morning.
Edit: I notticed that choosing a row out of the PERSON's data table makes the Range().Interior.Color function works properly, the problem is inside the range.
All right,
Thanks to #Thomas Inzina comment, I realized that the formula "=MOD(ROW(),2)<>0" should be translated to my native excel language, e.i: Portuguese. Then the right translation is "=MOD(LIN();2)<>0". But, still I did not figure out why I was getting that weird behaviour that I showed in my question, instead I used this solution (with the proper formula) to solve my issue:
https://stackoverflow.com/a/15957075/1171721
I am satisfied with that since I got what I wanted, but still if anyone discovers why I got this strange behaviour using the old approach, I will be happy to test the proposed solution for the sake of learning.
I am trying to conditionally format a range of cells based on the number in the column to each cell groupings' left. Basically, if in row 13, the gray column to the left of each cell grouping = 0, then I want the whole cell grouping to its right to turn green, if = 15, turn yellow, if = 25 turn red. Row 12 is what is happening with my code right now and row 13 is what I want it to look like. I can't seem to get the loop correct.
Sub Highlight3()
For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 4) = "Highlight" Then
For j = 1 To 15
Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = rgbRed
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23= 15"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = rgbGold
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 25"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = rgbGreen
End With
Next j
End If
Next i
End Sub
Avoid Select because it's slow and unyieldy. Just directly assign your Ranges to variables and work with those.
Sub Highlight3()
For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row Step 2
If Cells(i, 4) = "Highlight" Then
For j = 1 To 15
Dim r As Range
Set r = Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4))
Dim checkAddress As String
checkAddress = Cells(i, j * 4 + 1).Address
With r.FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 0"
.Item(.Count).Interior.Color = rgbRed
.Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 15"
.Item(.Count).Interior.Color = rgbGold
.Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 25"
.Item(.Count).Interior.Color = rgbGreen
End With
Next j
End If
Next i
End Sub
Things to notice:
No more ugly use of selection - get the Range r once and do all the tasks with its conditional formatting in one clean block.
No longer sets the new conditional formats to have first priority. Edit that back in if necessary, but I was guessing that it was just something that the Macro Recorder did.
Builds the formatting formula to check against the address directly left of the first cell. Make sure that the expression for checkAddress is what you'd expect, because I had to infer it from your picture and code. If that area with the value 0/15/25 is actually two merged cells (kinda looks like it is), then make sure this formula is for the upper cell, because that cell will be the one that actually holds the value.
Again, hard to tell from just a picture, but it looks like each of your "rows" is actually two cells high (based on your code, too). So you actually want to step through values of i by 2 at a time, not 1 at a time.
If any of the assumptions I've just listed about your table's formatting are wrong, let me know and I'll help iron out any remain kinks in the code.
This should do what you want and also be a bit faster:
Sub Highlight3()
Dim i As Long, j As Byte, myCols As Range, myRng As Range
Set myCols = Range("$B:$D")
For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 4) = "Highlight" Then
If myRng Is Nothing Then
Set myRng = Intersect(Rows(i), myCols)
Else
Set myRng = Union(myRng, Intersect(Rows(i), myCols))
End If
i = i + 1 'skip the line after, because it will never have a value / merged cell
End If
Next
If myRng Is Nothing Then Exit Sub
For i = 4 To 60 Step 4
For j = 0 To 1
With myRng.Offset(j, i)
.Cells(1).Offset(-j).Activate
.FormatConditions.Delete 'if that does not interfer with other stuff, better use the next line
'If j = 0 Then myCols.Offset(, i).FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=0"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = rgbRed
.FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=15"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = rgbGold
.FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=25"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = rgbGreen
End With
Next
Next
End Sub
tested it locally and it worked... there may be issues which I can not know (better test it with a copy of your workbook).
The first part pushes all lines in a range which is used in the second part. This way, each pack of columns needs only 2 steps (no need to run EVERY line).
If you have any questions or problems with this code, just ask ;)
I am working with this macro that will look at a block of transactions, insert 3 rows between months, and then add the month and subtotal. The issue is that the break and totals are getting inserted at the beginning of the month instead of the end.
I have tried to adjust the shift but it either ends up giving me an error or the total ends up overriding an existing cell instead of going into a new row. This is a more complex macro than I have worked with before and I'm a little lost now, still working on learning VBA.
Option Explicit
Sub AddAndSum()
On Error GoTo lblError
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim shData As Worksheet, wbData As Workbook
Dim fr As Long, lr As Long, i As Long, lr2 As Long
Dim intMonth As Long, intYear As Long
Set wbData = ThisWorkbook
Set shData = wbData.Sheets("Sheet1")
fr = 13
lr = shData.Rows.Count
For i = fr To lr
With shData
If (IsDate(.Cells(i, 3).Value) And IsDate(.Cells(i - 1, 3).Value) And Month(.Cells(i, 3).Value) <> Month(.Cells(i - 1, 3).Value)) Or i = fr Then
intMonth = Month(.Cells(i, 3).Value)
intYear = Year(.Cells(i, 3).Value)
.Rows(i & ":" & i + 2).Insert Shift:=xlDown
.Cells(i + 1, 1).Value = "Monthly Total (" & MonthName(intMonth) & ")"
.Cells(i + 1, 2).Formula = "=SUMPRODUCT((MONTH($C$" & fr & ":$C$" & lr & ")=" & intMonth & ")*(YEAR($C$" & fr & ":$C$" & lr & ")=" & intYear & ")*$E$" & fr & ":$E$" & lr & ")"
i = i + 3
End If
End With
Next i
lblError:
If Err.Number <> 0 Then
MsgBox "Error (" & Err.Number & "): " & Err.Description, vbOKOnly + vbCritical
End If
GoTo lblExit
lblExit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculate
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
This line begins the insertion at Row i.
.Rows(i & ":" & i + 2).Insert Shift:=xlDown
You want to begin the insertion at row i+3, and you can accomplish that with the Offset method:
.Rows(i & ":" & i + 2).Offset(3).Insert Shift:=xlDown
You may also want to see this answer regarding best way of getting the "last row" in a column:
Error in finding last used cell in VBA
As you're currently doing lr = shData.Rows.Count that is 65,336 rows in Excel 2003, or 1,048,576 rows in Excel 2007+ and you almost certainly do not have that many data (otherwise an Insert would fail!), so your loop is cycling needlessly over a bunch of empty rows.
You need to change this row:
intMonth = Month(.Cells(i, 3).Value)
to
intMonth = Month(.Cells(i-1, 3).Value)
At the moment it is setting intMonth to the value of the current cell (which is the first cell of the next month) instead of the value of the previous cell (which contains the month you want to subtotal).
Then add a condition into your loop to add the last subtotal.
Also:
If (IsDate(.Cells(i, 3).Value) And IsDate(.Cells(i - 1, 3).Value) And Month(.Cells(i, 3).Value) <> Month(.Cells(i - 1, 3).Value)) Or i = fr Then
Should this be i = lr ? as you are checking for the last line in the sheet? At the moment will always put a subtotal after the first line. You'll need to update this value when you add the three subtotal lines in as well.
Having trouble with the below code I've written. It should be updating the entries of a graph that previously ran from DL5:HX5 to DL5:IU5, have around 100 sheets hence the loop. For some reason it's stepping through but I appear to have a semantic error. Was hoping somebody might shed some light as to what that was.
There are three figures, and I'm not sure this is the best way to access figures on multiple sheets (they're identical copies of one another, with different data.) The first two just extends the time series the additional columns (e.g. HX to IU), the last figure simply color formats a line to a different color (the line is split by projected and actual line fragments.)
Dim i As Integer
For i = 31 To ActiveWorkbook.Worksheets.Count
On Error Resume Next
Worksheets(i).ChartObjects("Chart 2").Activate
ActiveChart.SeriesCollection(1).Values = "='" & Worksheets(i).Name & "'!$DL$5:$IU$5"
ActiveChart.SeriesCollection(1).XValues = "='" & Worksheets(i).Name & "'!$DL$3:$IU$3"
Worksheets(i).ChartObjects("Chart 6").Activate
ActiveChart.SeriesCollection(1).Values = "='" & Worksheets(i).Name & "'!$DL$14:$IU$14"
ActiveChart.SeriesCollection(2).Values = "='" & Worksheets(i).Name & "'!$DL$15:$IU$15"
ActiveChart.SeriesCollection(3).Values = "='" & Worksheets(i).Name & "'!$DL$16:$IU$16"
ActiveChart.SeriesCollection(3).XValues = "='" & Worksheets(i).Name & "'!$DL$3:$IU$3"
Worksheets(i).ChartObjects("Chart 1").Activate
ActiveChart.SeriesCollection(1).Points(30).Border.Color = RGB(69, 114, 167)
ActiveChart.SeriesCollection(1).Points(30).Format.Line.ForeColor.RGB = RGB(69, 114, 167)
Next i
You should avoid activating/selecting where you can. Untested:
Sub Tester()
Dim i As Integer
Dim sht As Worksheet
For i = 31 To ActiveWorkbook.Worksheets.Count
Set sht = ActiveWorkbook.Sheets(i)
With sht.ChartObjects("Chart 2").Chart.SeriesCollection(1)
.Values = sht.Range("$DL$5:$IU$5")
.XValues = sht.Range("$DL$3:$IU$3")
End With
With sht.ChartObjects("Chart 6").Chart
.SeriesCollection(1).Values = sht.Range("$DL$14:$IU$14")
.SeriesCollection(2).Values = sht.Range("$DL$15:$IU$15")
.SeriesCollection(3).Values = sht.Range("$DL$16:$IU$16")
.SeriesCollection(3).XValues = sht.Range("$DL$3:$IU$3")
End With
With sht.ChartObjects("Chart 1").Chart.SeriesCollection(1).Points(30)
.Border.Color = RGB(69, 114, 167)
.Format.Line.ForeColor.RGB = RGB(69, 114, 167)
End With
Next i
End Sub
EDIT: renaming charts
For i = 31 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Sheets(i)
on error resume next
.chartobjects("Chart 13").Name = "Chart 2"
on error goto 0
End With
Next i