Sub Filter_Click()
Dim j As Integer, k As Integer
j = Worksheets.Count
Dim key1 As String
key1 = InputBox("Type Script Name", "Title")
For k = 1 To j
With Worksheets(k)
.Range("A1").AutoFilter field:=1, Criteria1:=key1
.Range("A1").AutoFilter field:=2, Criteria1:="26-nov-15"
End With
Next k
End Sub
Sub Clear()
Dim j As Integer, k As Integer
j = Worksheets.Count
For k = 1 To j
Worksheets(k).Range("A1").AutoFilter
Next k
End Sub
I am using above macros for filtering and to remove filter. Columns remains identical in all sheets. Currently I am using simple max function to find max value manually in all sheets after filtration. I will be more happy if macro will highlight max value row. Current picture is, in column D, have different text, such as CE and PE. In column L have numbers which we have to find maximum number. So match CE text from column D and find max value from column L. Again match PE text from column D and find max value from column L and highlight entire both rows. Lastly it should get undo when I run clear macro.
As a sheet formula, you can use =SUBTOTAL(), e.g.
=SUBTOTAL(104;C3:C33)
With the type argument above 100 the function will act only on visible cells and hence only display the max of all displayed cells. You could display the "filtered max" somewhere in the header area of your sheet(s) ... I usually do it just above the column headings.
Edit ... VBA
let's do a SUB which receives a Range and marks the MAX value in that range ... a second Boolean parameter selects only visible rows or all rows to be marked ... a third Boolean parameter selects if you set or remove your color mark ... classical loop construct
Sub MarkMax(MyR As Range, OnlyVisible As Boolean, UnDo As Boolean)
Dim Idx As Integer, Tmp As Integer
Idx = 2 ' first row to be compared against current MAX
Tmp = 1 ' first value is first MAX (against better knowledge)
Do While Idx <= MyR.Rows.Count
If MyR(Idx, 1) > MyR(Tmp, 1) Then
If (OnlyVisible And Not MyR(Idx, 1).EntireRow.Hidden) Or Not OnlyVisible Then
Tmp = Idx ' capture index of new MAX
End If
End If
Idx = Idx + 1 ' advance list
Loop
With MyR(Tmp, 1).Interior
If UnDo Then
.Pattern = xlNone ' remove color
Else
.Pattern = xlAutomatic ' set color
.Color = RGB(255, 0, 0)
End If
End With
End Sub
You would call it as MarkMax [L2:Lxxx], True, False to set color on MAX of currently visible rows, and MarkMax [L2:Lxxx], True, True to clear the mark.
Related
I have a script wherein I loop through a 9x9 array and if a cell contains a 0, it will change the number such that the number is unique across the row, column and a 3x3 square within. Every time one such cell is found and changed, I want to add that cell location to an array so that if it comes to be that the number that replaced the 0 is not optimal, I can easily go back to that cell that was changed and try a new number. How do I do this?
Below is the code I have written so far and I have denoted my "pseudo-code" with three apostrophes (''')
that further explains what I want it to do.
The Check Function determines whether a number from 1 to 9 can be placed in the current cell based on the conditions I mentioned (Sudoku Rules).
It deals with recursion so let me know if I need to explain in a more clear manner.
Sub Solve()
Dim x As Integer, y As Integer, row As Integer, col As Integer, rw As Integer, cl As Integer, a As Worksheet, puzzle As Range, n As Integer, num As Integer
Dim startcol As Integer, startrow As Integer, check1 As Boolean, check2 As Boolean, check3 As Boolean, r As Integer, c As Integer, x1 As Double, y1 As Double, z As Boolean
Dim fillednums(1 To 9, 1 To 9) As String
Set a = ThisWorkbook.Worksheets("Puzzle")
Set puzzle = a.Range(Cells(4, 4), Cells(12, 12))
startcol = 4
startrow = 4
For row = startrow To startrow + 8
For col = startcol To startcol + 8
If a.Cells(row, col).Value = 0 Then
For num = 1 To 9
If Check(col, row, num) = True Then
a.Cells(row, col).Value = num
'''Add cell address to array
Call Solve
ElseIf num = 9 And a.Cells(row, col).Value = 0 Then
'''Go back one index of the array (fillednums) and use check() function for numbers greater than the one in the cell and up to 9
'''If that still doesnt work, go back to cell before this one that was changed and check again (recursively)
'''Call Solve() again to try new number
'a.Cells(row, col).Value = 0
End If
Next num
End If
Next col
Next row
End Sub
For the recursion, you can start with the first empty cell in the puzzle. For each possible value, pass the next free cell to the child to check for a solution. The process continues until a solution is found (assuming valid puzzle).
The main Solve function must return True or False so the parent knows if a solution has been found.
Function GetNextCell(cc) ' get next free cell in puzzle
GetNextCell = Cells(cc.Row, cc.Column+1) ' move next column
If (GetNextCell.Column = 13) Then ' go to next row
GetNextCell = Cells(cc.Row+1, 4)
End If
If GetNextCell.Row = 13 Then ' off the grid
GetNextCell = Nothing ' no more cells
End If
If GetNextCell <> Nothing And GetNextCell.Value <> "" Then
GetNextCell GetNextCell(GetNextCell) ' skip filled cells
End If
Function Solve(cc) as Boolean
' we only care about our single cell
For num = 1 to 9 ' all possible values for this cell
cc.Value = num
If Check(cc.column, cc.row, num) Then ' so far so good
NextCell = GetNextCell(cc) ' get next cell for child to process
if NextCell = Nothing Then ' no more cells and current values work
Solve = True ' puzzle solved
Exit Function
Else ' call child with next cell
If Solve(NextCell) Then ' did child solve puzzle ?
Solve = True ' puzzle solved
Exit Function
End If
' Child could not find solution based on current values
End If
End If
Next
cc.Value = "" ' No solution found at this point, must revert back to parent to try next value
Solve = False ' no solution found
End Function
Solve(GetNextCell(Cells(4,3))) ' first empty cell in block, must return true
So i found this script on this site to color rows with the same cell-data and change the color when the celldata changes and it seems to work just fine, but i have two minor issues
It seems to only apply to the first 900 rows (I have an excel list with 8000+ rows)
It colors the entire row, is there a way to make it only color a certain part of the row?
Thanks in advance! here's the script:
Public Sub HighLightRows()
Dim i As Integer
i = 2 'start at 2, cause there's nothing to compare the first row with
Dim c As Integer
c = 2 'Color 1. Check http://dmcritchie.mvps.org/excel/colors.htm for color indexes
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 = 37 '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
Try this:
Public Sub HighLightRows()
Const START_ROW As Long = 2 '<< use a Constant for fixed values
Const VALUE_COL As Long = 1
Dim rw As Range, emptyCells As Long, i As Long, currentValue, tmp
Dim arrColors
arrColors = Array(37, 2)
Set rw = ActiveSheet.Rows(START_ROW)
currentValue = Chr(0) 'dummy "current value"
Do While emptyCells < 10 'quit after 10 consecutive empty cells
tmp = rw.Cells(VALUE_COL).Value
If Len(tmp) > 0 Then
If tmp <> currentValue Then
i = i + 1
currentValue = tmp 'save the new value
End If
'assign the color to a specific set of cells in the row
' starting at cell 1 and 5 columns wide
rw.Cells(1).Resize(1, 5).Interior.ColorIndex = arrColors(i Mod 2)
emptyCells = 0 'reset empty row counter
Else
emptyCells = emptyCells + 1 'increment empty row counter
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
End Sub
It looks like the code only evaluates if the cell is the same as the cell above it. Conditional formatting, as John Coleman said, would be more effective. With it values in the whole column can be evaluated instead of just adjacent ones. And, if I'm not mistaken, there's a setting to look for dup values since Excel 2007, so there doesn't have to be some kind of formula kung-fu to do it.
Unless I'm missing something, it's as simple as Conditional Formatting -> Highlight Cell Rules -> Duplicate Values.
I have three columns E(insufficient QTY) F(Too Slow) and G(Not Listed) They all have checkboxes in them. I need to link
E to H
F to I
G to J
The following code works nicely if there was only 1 column of checkboxes but I don't know how to improve the code to run by checkboxes in a certain column. Right now it just searches the entire sheet for checkboxes and links them to the desired column.
Sub LinkChecks()
'Update 20150310
i = 2
For Each cb In ActiveSheet.CheckBoxes
cb.LinkedCell = Cells(i, "I").Address
i = i + 1
Next cb
End Sub
Edit
Ok... let's try again:
Since the Check Box object does not have cell information for the cell it's located in, we will have to use the Offset property more creatively.
Since we know there are 3 check boxes per row, we can find the total number of check boxes and divide by 3 to find out how many rows there are.
Then by setting a Range to a single cell at the top of column "E", you can use the offset property on that cell.
Assuming you placed your Check Boxes on the sheet down column "E" sequentially, and then down column "F" next, then down "G", we can reset the offsets once we get to the last row of each column. (If you place the check boxes on the sheet in row order, you'll have to invert the loop logic.) (If you placed the check boxes on randomly, you are out of luck and will have to set your linked cells manually.)
Sub LinkChecks()
Dim rng As Range
Dim strColumn As String
Dim i As Integer
Dim intCount As Integer
Dim intRowCnt As Integer
Dim intRowOffset As Integer
Dim intColumnOffset As Integer
Dim dCnt As Double
i = 1 ' Your initial row offset
intCount = 0 ' A counter for total number of check boxes
intRowCnt = 0 ' A Row counter to find last row
intRowOffset = i ' Current Row offset from initial rng cell
intColumnOffset = 3 ' Current Column Offset (3 over from first check box column)
strColumn = "E" ' Set a starting Column of your first check box
Set rng = ActiveSheet.Cells(1, strColumn) ' Set initial rng cell
' Count how many check boxes are on the active sheet
For Each cb In ActiveSheet.CheckBoxes
intCount = intCount + 1
Next cb
' Since you know you have 3 check boxes per row,
' you can divide by 3 to get your row count
dCnt = intCount / 3
' *** Put test for remainder problems here ***
For Each cb In ActiveSheet.CheckBoxes
cb.LinkedCell = rng.Offset(intRowOffset, intColumnOffset).Address
intRowOffset = intRowOffset + 1
' Increment your row count until you get to last row
intRowCnt = intRowCnt + 1
If intRowCnt >= dCnt Then
intRowCnt = 0 ' Reset you row counter
intColumnOffset = intColumnOffset + 1 ' Increment Offset to the next column
intRowOffset = i ' Reset Row offset back to top row
End If
Next cb
End Sub
As long as your check boxes were placed on the sheet down each column, the above program should find the correct Linked Cell for each box.
If they were placed in a different order, then at least this code shows you how to set an initial Range cell and how you can reference other cells with an offset.
Hopefully this code or a combination of these ideas will help you with your problem. :)
I am trying to compare the values from one column of one sheet, with the values of another column of a different sheet, same workbook, though. It steps through each cell in the other column, and if the cell value, a string, does not exist in sheet2, then the row from sheet1 is copied over to sheet3. You can think of it like I'm comparing two arrays. I want to see if there are any values in Array1 that do not appear in Array2, and if they do not appear in Array1, the value is copied into Array3.
My main issue is I'm getting a type-mismatch error in line 5. The values contain strings. I am fairly new at Excel VBA and am trying to learn it on the fly. Any help would be greatly appreciated.
Sub search()
Dim count As Integer
count = 0
For Each i In Worksheets("Sheet1").Range("C2:C4503")
Set first_cell = Worksheets("Sheet1").Cells(i, 3) <-- Mismatch eror
For Each j In Worksheets("Sheet2").Range("X2:X4052")
Set second_cell = Worksheets("Sheet2").Cells(j, 24)
If second_cell = first_cell Then Exit For
Next j
count = count + 1
Set Worksheets("Sheet3").Cells(count, 1) = Worksheets("Sheet1").Cells(j, 1).Select
Next i
End Sub
Sub Search()
Dim rowNum As Long
Dim i As Range, f As Range
rowNum = 1
For Each i In Worksheets("Sheet1").Range("C2:C4503").Cells
If Len(i.Value) > 0 Then
'search for value on sheet2
Set f = Worksheets("Sheet2").Range("X2:X4052").Find( _
i.Value, , xlValues, xlWhole)
If f Is Nothing Then
'not found: copy row from sheet1>sheet3
i.EntireRow.Copy Worksheets("Sheet3").Cells(rowNum, 1)
rowNum = rowNum + 1
End If
End If
Next i
End Sub
The following:
For Each i In Worksheets("Sheet1").Range("C2:C4503")
...
Next i
iterates through the cells in the specified range; i is a Range object representing the current cell.
You are using it as in integer index in the following line:
Set first_cell = Worksheets("Sheet1").Cells(i, 3)
Hence the Type Mismatch.
I have the following:
Date ------- Cost
Jan £500
Jan £600
Feb £300
Feb £600
March £1000
March £500
The cost cells are coloured differently depending on its current status (confirmed green, unconfirmed white, semi-confirmed yellow), I need a formula to sum all costs that are for example, green and in February.
I'm aware VBA is required for this sort of colour function, and have found a useful one called colorfunction() that allows me to sum/count cells of colours using the following formula:
colorfunction(A1, B1:B5, FALSE)
A1 being the colour to compare the range against, and FALSE / TRUE returning the sum or count result.
However I cannot work this custom function into a MONTH() formula or SUMIF.
I could be completely over-complicating this so please point out any idiotic mistakes I'm making in trying to figure this out.
Add this Function to your VBA module in order to return a cells interior color index:
Function ColorIndex(rng As Range, _
Optional text As Boolean = False) As Variant
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant
If rng.Areas.Count > 1 Then
ColorIndex = CVErr(xlErrValue)
Exit Function
End If
iWhite = WhiteColorindex(rng.Worksheet.Parent)
iBlack = BlackColorindex(rng.Worksheet.Parent)
If rng.Cells.Count = 1 Then
If text Then
aryColours = DecodeColorIndex(rng, True, iBlack)
Else
aryColours = DecodeColorIndex(rng, False, iWhite)
End If
Else
aryColours = rng.Value
i = 0
For Each row In rng.Rows
i = i + 1
j = 0
For Each cell In row.Cells
j = j + 1
If text Then
aryColours(i, j) = _
DecodeColorIndex(cell, True, iBlack)
Else
aryColours(i, j) = _
DecodeColorIndex(cell, False, iWhite)
End If
Next cell
Next row
End If
ColorIndex = aryColours
End Function
Private Function WhiteColorindex(oWB As Workbook)
Dim iPalette As Long
WhiteColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &HFFFFFF Then
WhiteColorindex = iPalette
Exit Function
End If
Next iPalette
End Function
Private Function BlackColorindex(oWB As Workbook)
Dim iPalette As Long
BlackColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &H0 Then
BlackColorindex = iPalette
Exit Function
End If
Next iPalette
End Function
Private Function DecodeColorIndex(rng As Range, _
text As Boolean, _
idx As Long)
Dim iColor As Long
If text Then
iColor = rng.Font.ColorIndex
Else
iColor = rng.Interior.ColorIndex
End If
If iColor < 0 Then
iColor = idx
End If
DecodeColorIndex = iColor
End Function
Then to get the count of all cells with the color index of 14 (Green) use sumproduct as Follows:
=SUMPRODUCT(--(ColorIndex(B1:B100000)=14),B1:B100000)
This will return the sum of all cells in Range B1:B100000 with a Color of 14 (Green)
The Final example should look something like this:
Additionally if you prefer Sumifs over Sumproduct yopu have the option of using a helper Column. In the Column next to the Cost enter =ColorIndex(B1) and then drag down
Then in another cells Enter the Formula
=SUM(SUMIFS(B1:B10,C1:C10,14,A1:A10,{"FEB","MARCH"}))
Replacing the Months with the Months you'd like to sum (your oringal Title indicates this is your End goal).
This will sum the Cost values where the helper Row says the index is 14(Green) AND the month is either Feb or March
I realize you are asking for a programing answer, and I have no idea of the scope of your project.
Here is simple solution, without programing.
Filter by color, select the cells, the sum will be displayed at the bottom (i.e. 2100)