Im trying to loop this macro, which changes the color of the row based upon year, through all of my worksheets in a current workbook and can't seem to figure out how to do so. I've tried to piece some stuff together from other questions and answers to no avail. Any help would be appreciated. Here is the code:
Sub ExpirationYeartoColors()
Dim num As Integer, lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Select
For r = 2 To lr
Select Case Range("A" & r).Value
Case Is = "2015"
Range("A" & r).Interior.Color = RGB(181, 189, 0)
Case Is = "2016"
Range("A" & r).Interior.Color = RGB(0, 56, 101)
Case Is = "2017"
Range("A" & r).Interior.Color = RGB(0, 147, 178)
Case Is = "2018"
Range("A" & r).Interior.Color = RGB(155, 211, 221)
Case Is = "2019"
Range("A" & r).Interior.Color = RGB(254, 222, 199)
Case Is = "2020"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case "2020" To "2080"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case Is = "Unknown"
Range("A" & r).Interior.Color = RGB(197, 200, 203)
Case Is = "Available"
Range("A" & r).Interior.Color = RGB(247, 150, 91)
Case Is = "CommonArea"
Range("A" & r).Interior.Color = RGB(230, 230, 230)
Case Else
Range("A" & r).Interior.Color = RGB(255, 255, 255)
End Select
Next r
On Error GoTo ErrorHandler
' Insert code that might generate an error here
Exit Sub
ErrorHandler:
' Insert code to handle the error here
Resume Next
End Sub
I have calculated the count of number of worksheets available on the workbook and stored to a variable. Then used a for loop to loop through the entire workbook till the last worksheet.
The blocked code is the modified part on your code.
Also I see for the case 2020 - 2080, the formatting color is same.
Sub ExpirationYeartoColors()
Dim num As Integer, lr As Long, r As Long
t = ActiveWorkbook.Worksheets.Count
i = 0
For i = 1 To t
Worksheets("sheet" & i).Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Select
For r = 2 To lr
Select Case Range("A" & r).Value
Case Is = "2015"
Range("A" & r).Interior.Color = RGB(181, 189, 0)
Case Is = "2016"
Range("A" & r).Interior.Color = RGB(0, 56, 101)
Case Is = "2017"
Range("A" & r).Interior.Color = RGB(0, 147, 178)
Case Is = "2018"
Range("A" & r).Interior.Color = RGB(155, 211, 221)
Case Is = "2019"
Range("A" & r).Interior.Color = RGB(254, 222, 199)
Case Is = "2020"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case "2021" To "2080"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case Is = "Unknown"
Range("A" & r).Interior.Color = RGB(197, 200, 203)
Case Is = "Available"
Range("A" & r).Interior.Color = RGB(247, 150, 91)
Case Is = "CommonArea"
Range("A" & r).Interior.Color = RGB(230, 230, 230)
Case Else
Range("A" & r).Interior.Color = RGB(255, 255, 255)
End Select
Next r
Next i
On Error GoTo ErrorHandler
' Insert code that might generate an error here
Exit Sub
ErrorHandler:
' Insert code to handle the error here
Resume Next
End Sub
This will loop through all the sheets and do the formatting. The code is tested and is working fine
Here is your answer...you need a variable to count the sheets then put your loop inside another "for" to go through all the sheets.
Or you could probably use a while if you wanted..
There are a few ways to loop through the worksheets in a workbook. I prefer the worksheet index method which simply identifies the worksheet according to its position in the worksheet queue.
Sub ExpirationYeartoColors()
Dim w As Long, lr As Long, r As Long, vVAL As Variant
For w = 1 To Worksheets.Count
With Worksheets(w)
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
vVAL = .Range("A" & r)
If IsNumeric(vVAL) Then
'treat numbers as numbers!!!
vVAL = Int(vVAL) 'maybe vVAL = Year(vVAL) ?
Select Case vVAL
Case 2015
.Range("A" & r).Interior.Color = RGB(181, 189, 0)
Case 2016
.Range("A" & r).Interior.Color = RGB(0, 56, 101)
Case 2017
.Range("A" & r).Interior.Color = RGB(0, 147, 178)
Case 2018
.Range("A" & r).Interior.Color = RGB(155, 211, 221)
Case 2019
.Range("A" & r).Interior.Color = RGB(254, 222, 199)
Case 2020
.Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case 2021 To 2080
.Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case Else
.Range("A" & r).Interior.Pattern = xlNone
End Select
Else
Select Case vVAL
Case Is = "Unknown"
.Range("A" & r).Interior.Color = RGB(197, 200, 203)
Case Is = "Available"
.Range("A" & r).Interior.Color = RGB(247, 150, 91)
Case Is = "CommonArea"
.Range("A" & r).Interior.Color = RGB(230, 230, 230)
Case Else
.Range("A" & r).Interior.Pattern = xlNone
End Select
End If
Next r
End With
Next w
On Error GoTo ErrorHandler
' Insert code that might generate an error here
Exit Sub
ErrorHandler:
' Insert code to handle the error here
Resume Next
End Sub
There are a number of unanswered questions; particularly about the nature of the data. However, you should be treating numbers as numbers especially if you want to use them in something like Case "2020" To "2080". I've tried to determine the nature of the values and treated text and numbers separately. This compiles but with no sample data or answers to the comments posed I cannot guarantee its validity.
Setting the .pattern to xlNone removes the interior fill rather than painting it white.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
There is an alternative approach using conditional formatting (CF).
The advantage is that once the CF is set up, th formatting of cells will respond to any values that are changed.
You could use VBA code to add CF to all sheets by looping through all sheets in the workbook and running VBA code to add it. OR you could add it manually as follows.
I understand you might need to write VBA code for other reasons and if you do the other answers are good, but I suspect this might work for you.
Select all rows on a sheet (or as many as you need).
Ribbon>HOME>Conditional formatting
Choose: "Use a Formula to determine which cells to format"
Enter this formula "=AND($A1=2010,$A1>0)"
(it assume your data value is in column A
it assumes the first row you selected was row 1)
Enter the formatting you want for the whole row when year in column A=2010
Add one conditional formatting for every year.
I recommend you record a macro and just change it as needed to add CF for every year to every sheet.
Sometimes simple is best.
Harvey
Related
Source code:
Dim TH As Double
Lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
'starting point
sRow = 2
'Loop in all cells
For i = sRow To Lr
'check if cell value are not same
If Cells(i, 1).Value <> Cells(i + 1, 1) Then
'if not same then merge all the above cells
Range("I" & sRow, "I" & i).Resize(, 7).Select
TH = Application.WorksheetFunction.Sum(Selection)
**If TH <> 40 Then**
Range("A" & sRow, "A" & i).Interior.Color = RGB(255, 0, 0)
End If
In this Code:
If TH <> 40 Then condition not working when ever the TH is Calculated on Decimal Numbers.
Such as 3.60,0.80,4.60 Sum is coming as 40 when use SUM Function but If Condition is not getting fulfilled.
Please Help
I have tried this, putting decimals all over and it works:
Sub TestMe()
Dim lr As Long
Dim TH As Double
Dim i As Long
lr = 10
For i = 1 To lr
If Cells(i, 1).Value <> Cells(i + 1, 1) Then
Range("I" & 6, "I" & i).Resize(, 7).Select
TH = Application.WorksheetFunction.Sum(Selection)
If TH <> 40 Then
Range("A" & 6, "A" & i).Interior.Color = RGB(255, 0, 0)
End If
End If
Next
End Sub
Thus, probably the problem is the way you put the decimals. In some systems (German or French), the decimal separator is ,, while in English systems it is a point - .. Thus, you might be using the wrong one.
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.
I need to apply the following IF functions to every row in columns J, L, and S so that the correct date value is printed in the corresponding cell in row T. For example, cell T2 will have a date printed in it based on the outcome of running these IF functions on J2, L2, and S2; cell T3 will have a date printed in it based on the outcome of running these IF functions on J3, L3, and S3; and so on. Here's what I have got:
Sub Test1()
Set firstDate = Range("S2")
If Range("J2") = "GS/CA/SL/GW" Then
If Range("L2") = "1" Or "2" Or "3" Then
Range("T2") = DateAdd("ww", 52, firstDate)
End If
If Range("L2") = "4" Or "5" Or "6" Then
Range("T2") = DateAdd("ww", 104, firstDate)
End If
If Range("L2") = "7" Or "8" Or "9" Then
Range("T2") = DateAdd("ww", 156, firstDate)
End If
End If
End Sub
It works on one set of cells at a time if I just redefine all the ranges, but I thought there must be an easier way than pasting and editing the code ~3500 times for all the rows I have to run it on. Any help would be appreciated!
If I follow your question correctly I believe you just need a simple loop to adapt your current code.
Try this:
Sub loopDate()
Application.ScreenUpdating = False
Dim LastRow As Integer
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim firstDate As Range
Dim i As Long
For i = 2 To LastRow
If Range("J" & i) = "GS/CA/SL/GW" Then
Set firstDate = Range("S" & i)
Select Case Range("L" & i)
Case 1 To 3
Range("T" & i) = DateAdd("ww", 52, firstDate)
Case 4 To 6
Range("T" & i) = DateAdd("ww", 104, firstDate)
Case 7 To 9
Range("T" & i) = DateAdd("ww", 156, firstDate)
End Select
End If
Next i
Application.ScreenUpdating = True
End Sub
Note that I started the loop at row 2 since that's what your example used and go until the last used row in column A. I also changed your if logic to a select case statement for improved readability.
You may want to just use an equation in cell T? instead of using VBA but since I don't know the details I'll assume you have a good reason.
I have a VBA spreadsheet that allows a user to add the contents of another spreadsheet, format it, calculate totals, and add a pie chart. It is mostly working fine except there is one month tab that is creating a series per data point when we want all data points in one pie.
Here is the function to create the pie chart.
Sub AddChart(CurrentWorkSheet As Worksheet)
Dim FirstRow As Integer
Dim LastRow As Integer
Dim FirstColumn As String
Dim LastColumn As String
Dim DataRange As Range
Dim i As Integer
FirstRow = RowCount(CurrentWorkSheet) + 2
LastRow = FirstRow + 4
Set DataRange = CurrentWorkSheet.Range("I" & FirstRow & ":I" & LastRow)
Dim MyChart As Chart
Set MyChart = CurrentWorkSheet.Shapes.AddChart(xlPie).Chart
MyChart.SetSourceData Source:=DataRange
MyChart.SeriesCollection(1).HasDataLabels = True
For i = 1 To MyChart.SeriesCollection(1).Points.Count
If i = 1 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(0, 176, 80)
ElseIf i = 2 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(255, 0, 0)
ElseIf i = 3 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(112, 48, 160)
ElseIf i = 4 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(0, 0, 0)
MyChart.SeriesCollection(1).Points(i).DataLabel.Font.Color = RGB(255, 255, 255)
ElseIf i = 5 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(0, 112, 192)
Else
End If
Next
MyChart.SeriesCollection(1).XValues = CurrentWorkSheet.Range("H" & CStr(FirstRow) & ":H" & CStr(LastRow))
End Sub
In this workbook there is a YTD worksheet and a worksheet for each month. When it gets to April the pie has one color. All of the other months are fine.
The data set is as follows:
ATTACHMENT 962.31
DAMAGE 3,279.94
MODIFICATIONS 451.00
REPAIRS 5,239.78
TIRES 1,979.04
The data range is rows 51-55.
=SERIES(,'Apr 2014'!$H$51:$H$55,'Apr 2014'!$I$51,1)
When I look at the series in Excel there are 5 listed, the first is ATTACHMENT and the last 4 are 1. Each month is using the same function as well as the YTD tab and they are all OK except April.
Any ideas what could be causing it?
I think I figured it out. I changed the following
Set DataRange = CurrentWorkSheet.Range("I" & FirstRow & ":I" & LastRow)
to
Set DataRange = CurrentWorkSheet.Range("I" & CStr(FirstRow) & ":I" & CStr(LastRow))
Seems to be working now. Unsure why it worked OK on the other tabs....
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