I have a macro that iterates through some rows, to update the colouring of data points in a related chart. The rows can be hidden by the user, so it checks the hidden value, i.e.
Do While wsGraph.Cells(RowCounter, 1) <> ""
If wsGraph.Rows(RowCounter).Hidden = False Then
'code here
End If
RowCounter = RowCounter + 1
Loop
This code takes 69 seconds to run. If I take the test for the hidden row out, it takes 1 second to run.
Is there a better way to do this test, otherwise I will have to tell the users they can't use the hide function (or deal with a 69 second delay).
Thanks
Here's the full code, as requested.
The graph is a bar graph, and I colour the points based on the values being in certain ranges, eg: over 75% = green, over 50% = yellow, over 25% = orange, else red. There's a button on the form to recolour the graph, that executes this code.
If someone filters the data table, what's happening is this: say the first 20 rows were over 75%, and were initially coloured green. After filtering the table, say only the first 5 are over 75%. The graph still shows the first 20 as green. So this button with the macro recolours the bars.
' --- set the colour of the items
Dim iPoint As Long
Dim RowCounter As Integer, iPointCounter As Integer
Dim wsGraph As Excel.Worksheet
Set wsGraph = ThisWorkbook.Worksheets(cGraph5)
wsGraph.ChartObjects("Chart 1").Activate
' for each point in the series...
For iPoint = 1 To UBound(wsGraph.ChartObjects("Chart 1").Chart.SeriesCollection(1).Values)
RowCounter = 26
iPointCounter = 0
' loop through the rows in the table
Do While wsGraph.Cells(RowCounter, 1) <> ""
' if it's a visible row, add it to the counter, if it's the same counter as in the series, exit do
If wsGraph.Rows(RowCounter).Hidden = False Then
iPointCounter = iPointCounter + 1
If iPointCounter = iPoint Then Exit Do
End If
RowCounter = RowCounter + 1
Loop
' colour the point from the matched row in the data table
Dim ColorIndex As Integer
If wsGraph.Cells(RowCounter, 5) >= 0.75 Then
ColorIndex = ScoreGreen
ElseIf wsGraph.Cells(RowCounter, 5) >= 0.5 Then
ColorIndex = ScoreYellow
ElseIf wsGraph.Cells(RowCounter, 5) >= 0.25 Then
ColorIndex = ScoreOrange
ElseIf wsGraph.Cells(RowCounter, 5) >= 0 Then
ColorIndex = ScoreRed
Else
ColorIndex = 1
End If
ActiveChart.SeriesCollection(1).Points(iPoint).Interior.ColorIndex = ColorIndex
Next
Try Special Cells
Sub LoopOverVisibleCells()
Dim r As Range
Dim a As Range
dim cl As Range
Set r = ActiveSheet.UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
For Each a In r.Areas
For Each cl In a
' code here
Next
Next
End Sub
This is what I've done, using Chris's suggestion. It doesn't answer why the hidden check is so slow, but it's a more efficient way of doing the recolouring:
Dim myrange As range
Set myrange = wsGraph.range("E26:E304").SpecialCells(xlCellTypeVisible)
Dim i As Integer
For i = 1 To myrange.Rows.Count
If myrange.Cells(i, 1) >= 0.75 Then
ColorIndex = ScoreGreen
ElseIf myrange.Cells(i, 1) >= 0.5 Then
ColorIndex = ScoreYellow
ElseIf myrange.Cells(i, 1) >= 0.25 Then
ColorIndex = ScoreOrange
ElseIf myrange.Cells(i, 1) >= 0 Then
ColorIndex = ScoreRed
Else
ColorIndex = 1
End If
ActiveChart.SeriesCollection(1).Points(i).Interior.ColorIndex = ColorIndex
Next i
Related
Code:
Public Sub HighLightRows()
Dim i As Integer
i = 2
Dim c As Integer
c = 2 'Color 1
'Dim colorIndex As XlColorIndex: colorIndex = Application.Dialogs(xlDialogEditColor).Show(10)
'MsgBox colorIndex
Do While (Cells(i, 1) <> "")
If (Cells(i, 1) <> Cells(i - 1, 1)) Then 'check for different value in cell A (index=1)
If c = 2 Then
c = 24 'color 2
Else
c = 2 'color 1
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.colorIndex = c
i = i + 1
Loop
End Sub
This code works perfectly and changes color when value in the column changes. But the colors are specified in the code. I want the user to select color of his/her choice.
Output that I am getting with above code:
What I want the code to do:
Open the color palette.User selects a color.Color index is passed to a variable.When value changes, rows is colored alternatively with white & the color selected.
Eg. if user selects blue from palette, the rows will be blue & white with alternate groups.if user selects green from palette, the rows will be green & white with alternate groups.
I tried including this code :
Dim colorIndex As XlColorIndex: colorIndex = Application.Dialogs(xlDialogEditColor).Show(10)
MsgBox colorIndex
palette opens up perfectly, but MsgBox colorIndex gives me -1 as output.
I cant seem to get this to work. Any change in code.?
The Dialogs(xlDialogEditColor) returns True = -1 if a color was selected and False = 0 if the user pressed cancel. To get the selected color use ActiveWorkbook.Colors(10) like in the example below.
Option Explicit
Public Sub ColorPaletteDialogBox()
Dim lcolor As Long
If Application.Dialogs(xlDialogEditColor).Show(10) = True Then
'user pressed OK
lcolor = ActiveWorkbook.Colors(10)
ActiveCell.Interior.Color = lcolor
Else
'user pressed Cancel
End If
End Sub
So for your loop you could use something like …
Option Explicit
Public Sub HighLightRows()
Dim c As Integer
c = 2 'Color 1
Dim i As Long 'integer is too small for row counting!
i = 2
If Application.Dialogs(xlDialogEditColor).Show(10) = True Then
Do While (Cells(i, 1) <> "")
If (Cells(i, 1) <> Cells(i - 1, 1)) Then 'check for different value in cell A (index=1)
If c = 2 Then
c = 10 'color 2
Else
c = 2 'color 1
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.colorIndex = c
i = i + 1
Loop
Else
'user pressed Cancel
End If
End Sub
I have the code below that does the following.
It finds the text “EE Only” in column A and records the row number.
It then adds four rectangles with the first one in the recorded row number and the other three in the three rows below.
It then formats the rectangles with no fill and a black border.
I have dim c as Integer and c = 2. I then use that as the column. So far everything is working as it should. The problem I’m having is that I need the column number to increase by one for every column after B that has something in row 3. In other words; the first set of shapes will always be in column B. After that if there is something in C3 then I need the column number to be increase by 1 and the shapes added to column C. If something is in D3 increase c by 1 and add shapes to column D and so forth. The first time row 3 is blank the loop would stop.
I’ve tried a couple of different things and I’m at a completely loss. The other issue I’m having is, if I run the code with c = 2 the shapes are formatted properly. If I then leave those shapes and manually change to c = 3 and run the code again, the new set of shapes have a blue fill. Again, tried everything I could find and nothing works.
Sub AddShapes()
Const TextToFind As String = "EE Only"
Dim ws As Worksheet
Dim RowNum As Range
Dim SSLeft As Double
Dim SSTop As Double
Dim SS As Range
Set ws = ActiveSheet
Dim c As Integer
c = 2
Set RowNum = ws.Range("A:A").Find(what:=TextToFind, lookat:=xlWhole)
Set SS = Cells(RowNum.Row, c)
SSLeft = Cells(RowNum.Row, c).Left + (Cells(RowNum.Row, c).Width) / 4
'Add four rectangles
Dim y As Integer
For y = 0 To 3
SSTop = Cells(RowNum.Row + y, c).Top + ((Cells(RowNum.Row + y, c).Height) / 2) - 5
Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, SSLeft, SSTop, 10, 10)
Next
'Format them
ws.DrawingObjects.Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
End Sub
I wasn't 100% sure about your requirements, but here's my best interpretation of it. Not I defined a new subroutine for the rectangles section, see comments for details
Sub AddShapes()
Const TextToFind As String = "EE Only"
Dim ws As Worksheet
Dim RowNum As Range
Set ws = ActiveSheet
Dim c As Integer
c = 2
Set RowNum = ws.Range("A:A").Find(what:=TextToFind, lookat:=xlWhole)
Call Rectangles(RowNum.row, c, ws) ' call the rectangles function for our first instance
c = c+1 ' increment the column by one so we're not on the same column
Do While Not IsEmpty(Cells(3,c).Value) 'Loop through each column until the 3rd row is empty
Call Rectangles(3,c,ws) ' call our rectangles function on the 3rd row in the current column (c)
c=c+1 ' increment the column
Loop
End Sub
Sub Rectangles(row As Integer, c As Integer, ws As Worksheet) ' we define a separate sub to draw the rectangles so that we can call it again and again
Dim SSLeft As Double
Dim SSTop As Double
Dim SS As Range
Set SS = Cells(row, c)
SSLeft = Cells(row, c).Left + (Cells(row, c).Width) / 4
'Add four rectangles
Dim y As Integer
For y = 0 To 3
SSTop = Cells(row + y, c).Top + ((Cells(row + y, c).Height) / 2) - 5
Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, SSLeft, SSTop, 10, 10)
Next
'Format them
ws.DrawingObjects.Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
End Sub
I have a spreadsheet with 50K values on it.
I want it a code to go through every value and check to see if it ends in a 5 or 0 and if it doesn't not to round to the nearest of the two.
I tried this as my code
Sub Round_flow()
Dim nxtRow As Long, found As Boolean, i As Long, minus As Long, plus As Long, equal As Long, cell As Boolean, f As Integer
nxtRow = 2
found = False
i = Sheet1.Cells(nxtRow, 2)
minus = -2
equal = 0
While Not found 'finds last used row
If (Cells(nxtRow, 2) = "") Then
found = True
Else
nxtRow = nxtRow + 1
End If
Wend
For f = 2 To i
For minus = -2 To 168 Step 5
If ActiveCell.Value <> equal Then
While Not cell
plus = minus + 4
equal = minus + 2
If minus <= ActiveCell.Value <= plus Then
Sheet1.Cells(i, 2).Value = equal
cell = True
End If
Wend
End If
Next minus
Next f
Essentially what I was trying to do is say here is the last row, i want to check every value from i to last filled row to see if it falls between any plus and minus value (+-2 of the nearest 5 or 0) then have whatever activecell.value be replaced by the 0 or 5 ending digit 'equal' which changes with each iteration.
Ok, that seems way too complicated. To round to 5, you just multiply by 2, round, then divide by 2. Something like this will do the trick:
Dim NumberToBeRounded as Integer
Round(NumberToBeRounded *2/10,0)/2*10
*2 and /2 to get it to be rounded to 5, and /10 *10 to make the round function round for less than 0 decimals.
(I have to admit, I don't really understand what your code is trying to do, I hope I didn't completely misunderstand your needs.)
This should do the trick:
Sub Round_flow()
For f = 2 To Cells(1, 2).End(xlDown).Row
Cells(f, 2).Value = Round(Cells(f, 2).Value * 2 / 10) / 2 * 10
Next
End Sub
Cells(1, 2).End(xlDown).Row finds the last used cell, unless you have no data; if that can happen, add some code to check if you have at least 2 rows. Or you can use the Usedrange and SpecialCells(xlLastCell) combo to find the last used row of your table...
Another way:
Sub RoundEm()
Dim wks As Worksheet
Dim r As Range
Dim cell As Range
Set wks = ActiveSheet ' or any other sheet
On Error Resume Next
Set r = wks.Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not r Is Nothing Then
For Each cell In r
cell.Value2 = Round(cell.Value2 / 5, 0) * 5
Next cell
End If
End Sub
I am trying to create two arrays: one having the row numbers of orange cells and the other with the row numbers of blue cells. I've been trying to debug this code for a while but it is giving me the error: "Compile error: Object required"; whilst highlighting in yellow the first line of the function: "Function ArrayOrangeBlue()". I'm new to VBA and I'm pretty sure I'm missing something in the syntax.
Do you have any feedback please?
Sub CommandButton1_Clicked()
ArrayOrangeBlue
End Sub
Function ArrayOrangeBlue()
Dim i As Integer 'row number'
Dim j As Integer 'orange counter'
Dim k As Integer 'blue counter'
Dim l As Integer
Dim m As Integer
Dim blue(1 To 1000) As Double
Dim orange(1 To 1000) As Double
'Starting Row'
Set i = 10
'Initialize orange and blue counters to 1'
Set j = 1
Set k = 1
Set l = 10
Set m = 10
'Loop until Row 1000'
Do While i <= 1000
'Dim cell As Range
'Set cell = ActiveSheet.Cells(i, 1)
'If cell colour is Orange- note absolute row number (i) in array: orange'
If Cells(i, 1).Interior.Color = 9420794 Then
orange(j) = i
Sheets("Detail analysis").Cells(l, 15) = i
j = j + 1
l = l + 1
'MsgBox ("This one is Orange")
Else
'If cell colour is Blue- note absolute row number (i) in array: blue'
If Cells(i, 1).Interior.Color = 13995347 Then
blue(k) = i
Sheets("Detail analysis").Cells(m, 16) = i
k = k + 1
m = m + 1
'MsgBox ("This one is Blue")
End If
End If
i = i + 1
Loop
End Function
so finally I managed to resolve my code to find and note cells with certain colours.
here the code stores the row numbers of the Orange cells in the array orange() and in column 1 of array Arr() and Blue cells in the array blue() and in column 2 of array Arr().
I removed the "Set" command when initialising the variables.
However, more critically, I was required to specify the sheet in each If statement.
I hope this helps someone else.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayOrangeBlue Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Dim i As Integer ' row number '
Dim j As Integer ' orange counter '
Dim k As Integer ' blue counter '
Dim l As Integer
Dim m As Integer
Dim blue(1 To 50) As Double
Dim orange(1 To 50) As Double
Dim green As Double
' Starting Row '
i = 10
' Initialize orange and blue counters to 1 '
j = 1
k = 1
l = 10
m = 10
Dim Arr(100, 2) As Double
' Loop until Row 1000 '
Do While i <= 1000
''''' If cell colour is Orange- note absolute row number (i) in array: orange '
If Sheets("Detail analysis").Cells(i, 1).Interior.Color = 9420794 Then
orange(j) = i
Arr(j, 1) = i
j = j + 1
Else
''''''''' If cell colour is Blue- note absolute row number (i) in array: blue '
If Sheets("Detail analysis").Cells(i, 1).Interior.Color = 13995347 Then
blue(k) = i
Arr(k, 2) = i
k = k + 1
Else
''''''''''''' If cell colour is Gren- store the absolute row number (i) in: green '
If Sheets("Detail analysis").Cells(i, 1).Interior.Color = 5296274 Then
Arr(j, 1) = i
green = i
End If
End If
End If
i = i + 1
Loop
I am looking to find out how I can remove ALL duplicate rows (when duplicates exist in the first column) using a VBA macro.
Currently Excel macros delete all duplicate instances EXCEPT for the first instance, which is totally not what I want. I want absolute removal.
A bit shorter solution done for quick morning training:
Sub quicker_Option()
Dim toDel(), i As Long
Dim RNG As Range, Cell As Long
Set RNG = Range("a1:a19") 'set your range here
For Cell = 1 To RNG.Cells.Count
If Application.CountIf(RNG, RNG(Cell)) > 1 Then
ReDim Preserve toDel(i)
toDel(i) = RNG(Cell).Address
i = i + 1
End If
Next
For i = UBound(toDel) To LBound(toDel) Step -1
Range(toDel(i)).EntireRow.Delete
Next i
End Sub
Store the first instance's cell for later deleting.
Then go deleting duplicates until the end.
Dim F as integer, S as integer 'indices for First and Second cells to be compared
Dim Deleted as boolean 'indicates if second line was deleted
Dim First as Range, Second as Range 'First and second cells to be compared
Dim Start as string 'Indicates the position of the first cell's start
Start = "A1" 'can be as you like
Set First = Sheet1.Range(Start) 'Sets the start cell
F = 0 '
Do While First.Value <> "" 'loop while sheet contains data in the column
S = F + 1 'second cell is at least 1 cell below first cell
Deleted = false 'no second cell was deleted yet
Set Second = First.Offset(S,0) 'second cell is an offset of the first cell
Do While Second.Value <> "" 'loop while second cell is in sheet's range with data
if Second.Value = First.Value then 'if values are duplicade
Second.EntreRow.Delete 'delete second cell
Deleted = true 'stores deleted information
else 'if not, second cell index goes next
S = S + 1;
end if
Set Second = First.Offset(S, 0) 'sets second cell again (if deleted, same position, if not deleted, next position
Loop
if Deleted then 'if deleted, should delete first cell as well
First.EntireRow.Delete
else
F = F + 1 'if no duplicates found, first cell goes next
end if
Set First = Sheet1.Range(Start).Offset(F,0) 'sets first cell again (if deleted, same position, if not, next)
Loop
I am using this code to create an Auto reconciliation of general ledger control accounts where if any cell with equal value but opposite sign is cut to sheet 2; hence left with only reconciliation item.
the code:
sub autoRecs()
dim i as long
Application.ScreenUpdating = False
Application.StatusBar = True
Dim i As Long
Cells(5, 6).Select
Dim x As Long
Dim y As Long
x = ActiveCell.Row
y = x + 1
Do Until Cells(x, 6) = 0
Do Until Cells(y, 6) = 0
Application.StatusBar = "Hey Relax! You can rely on me......"
If Cells(x, 6) = Cells(y, 6) * -1 Then
Cells(x, 6).EntireRow.Cut (Worksheets(2).Cells(x, 6).EntireRow)
Cells(y, 6).EntireRow.Cut (Worksheets(2).Cells(y, 6).EntireRow)
Cells(x, 6).Value = "=today()"
Cells(y, 6).Value = "=today()"
Else
y = y + 1
End If
Loop
x = x + 1
y = x + 1
Loop
Application.StatusBar = False
End Sub
Sub deleteBlankCells()`this is to delete unnecessary cells after run the above macro`
Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp)).Select
For i = Selection.Rows.Count To 1 Step -1
Application.StatusBar = "OOH! I'm cleaning all the blanks for you....."
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
Application.StatusBar = False
End Sub
I like to work with arrays within VBA, so here is an example.
Assume the data represents the currentregion around A1, but that is easily changed
Read the source data into an array
Check each item in column one to ensure it is unique (countif of that item = 1)
If unique, add the corresponding row number to a Collection
Use the size of th collection and the number of columns to Dim a results array.
Cycle through the collection, writing the corresponding rows to a results array.
Write the results array to the worksheet.
As written, the results are placed to the right of the source data, but could also replace it, or be placed on a different sheet.
Option Explicit
Sub RemoveDuplicatedRows()
Dim vSrc As Variant, vRes() As Variant
Dim rSrc As Range, rRes As Range
Dim colUniqueRows As Collection
Dim I As Long, J As Long
'assume data starts in A1 and represented by currentregion
Set rSrc = Range("a1").CurrentRegion
vSrc = rSrc
Set rRes = rSrc.Offset(0, UBound(vSrc, 2) + 2)
'get collection of non-duplicated rows
Set colUniqueRows = New Collection
For I = 1 To UBound(vSrc)
If WorksheetFunction.CountIf(rSrc.Columns(1), vSrc(I, 1)) = 1 Then _
colUniqueRows.Add I
Next I
'Make up results array
ReDim vRes(1 To colUniqueRows.Count, 1 To UBound(vSrc, 2))
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vSrc, 2)
vRes(I, J) = vSrc(colUniqueRows(I), J)
Next J
Next I
rRes.EntireColumn.Clear
rRes.Resize(UBound(vRes)) = vRes
End Sub