I want to unhide a single row if an ENTIRE range of rows is hidden. I want to hide this row if even a SINGLE row within the range is unhidden. What is the syntax for this? My current code is as follows:
Public Sub MySub()
Application.ScreenUpdating = False
With Range("A1:A5")
.EntireRow.Hidden = False
For Each cell In Range("A1:A5")
Select Case cell.Value
Case Is = "-"
cell.EntireRow.Hidden = True
End Select
Next cell
End With
Application.ScreenUpdating = True
End Sub
I think I understand. How's this:
Sub test()
Dim cel As Range, rng As Range
Dim hideRow&, numDashes&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
For Each cel In rng
If cel.Value = "-" Then
numDashes = numDashes + 1
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
If numDashes = rng.Count Then
' If all cells in the range are '-'
Rows(hideRow).EntireRow.Hidden = False
Else
Rows(hideRow).EntireRow.Hidden = True
End If
End Sub
I'm kind of assuming that you want to hide/unhide Row 6, since it's one below your range's last row. Therefore, I created a variable to hold this. This way, if you want to change your range to say A1:A100, all you have to do is adjust the rng, and it'll look to hide/unhide row 101. Of course, if you just need it to be 6, then just do hideRow = 6.
Edit: For fun, I tried to reduce the use of the counting variable numDashes and tried to the part where you check your range for all - to be more concise. The below should work too, but might need a tweak or two:
Sub test2()
Dim cel As Range, rng As Range
Dim hideRow&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
'Check to see if your range is entirely made up of `-`
If WorksheetFunction.CountIf(rng, "-") = rng.Count Then
Rows(hideRow).EntireRow.Hidden = False
' If you want to stop your macro if ALL range values are "-", then uncomment the next line:
'Exit Sub
Else
Rows(hideRow).EntireRow.Hidden = True
End If
For Each cel In rng
If cel.Value = "-" Then
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
End Sub
You can do this with a formula in a helper column. I used this one for financial statements to suppress rows where multiple column are all zero to shorten up the report.
=IF(AND(SUM(A7:R7)<1,SUM(A7:R7)>-1),IF(OR(ISNUMBER(LEFT(H7,4)),ISBLANK(H7),ISERR(VALUE(LEFT(H7,4)))),"Show","Hide"),"Show").
Then filter the rows by that column.
Related
I have a range of values, I want to find the MIN, then highlight the row of this Min value.
Sub worstcase()
Set Rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(Rng)
Debug.Print worstcase
How can I highlight rows based on variable worstcase?
I have my static range, and find the min value, but now I need to highlight the row of the worstcase variable.
Highlight Row With Found Criteria
The code is highlighting each row where the minimum was found. Use Exit For to highlight only the first found.
The Code
Sub worstcase()
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
cell.EntireRow.Interior.ColorIndex = 3 ' Hightlight whole row.
'cell.Interior.ColorIndex = 5 ' Hightlight only cell.
'Exit For ' To highlight only the first found row.
End If
Next
End With
End Sub
EDIT:
Sub worstcase()
Const cFirst As Variant = "H"
Const cLast As Variant = "Q"
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
.Range(.Cells(cell.Row, cFirst), .Cells(cell.Row, cLast)) _
.Interior.ColorIndex = 3 ' Hightlight cells.
'Exit For ' To highlight only the first found cells.
End If
Next
End With
End Sub
You could do it thus.
Won't work though if you have a repeated minimum.
Also you could use conditional formatting and avoid VBA.
Sub worstcase()
Dim Rng As Range, worstcase, i As Long
Set Rng = Range("H44:H54")
With Rng
worstcase = Application.WorksheetFunction.Min(.Cells)
i = Application.Match(worstcase, .Cells, 0)
.Cells(i).EntireRow.Interior.Color = vbRed
End With
End Sub
Create a conditional formatting rule based on the following formula.
=$H44=min($H$44:$H$54)
This VBA will create a CFR for rows 44:54.
With worksheets("sheet1").range("44:54")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H44=min($H$44:$H$54)"
.FormatConditions(.FormatConditions.Count).Interior.Color = vbred
End With
I want to type a number in B3. If a number in the range B8 to B200 is larger than the value in B3, the cell in the range whose value is larger than that of B3's value will be cleared of its contents. (I tried doing this with the code attached)
(OR:
If a value is entered in B3, a drop down of all the values that are less than or equal to the value in B3 is generated (that way there is no way to exceed the value in B3).)
Sub ProcessLineNumberValidation()
Dim QTY As Integer
Dim ProcessNum As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Ozone Generator")
QTY = ws.Sheets("Ozone Generator").Cells(3, 2).Value
For i = 8 To 200
ProcessNum = ws.Sheets("Ozone Generator").Cells(i, 2).Value
If ProcessNum > QTY Then
ws.Sheets("Ozone Generator").Cells(i, 2).ClearContents
End If
Next i
End Sub
First, you use Set ws = Thisworkbook.Sheets("Ozone Generator")
Then, you use ws.Sheets("Ozone Generator") on multiple lines which is the likely source of your problem. If you substitute ws back in to the above line of code you get:
Thisworkbook.Sheets("Ozone Generator").Sheets("Ozone Generator")
Which is not a valid cell reference. Just use ws.Cells(.... which will result in the below code (corrected for problem and applied more standard spacing, ordering, & indentation methods to code)
Option Explicit
Sub ProcessLineNumberValidation()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Ozone Generator")
Dim QTY As Integer, ProcessNum as Integer, i
QTY = ws.Cells(3, 2).Value
For i = 8 To 200
ProcessNum = ws.Cells(i, 2).Value
If ProcessNum > QTY Then
ws.Cells(i, 2).ClearContents
End If
Next i
End Sub
You can consider this alternative that has the same output but will be quicker. For Each loops are faster than For i = loops when looping through ranges like this. Also toggling off ScreenUpdating will make this look cleaner from a user standpoint.
Sub ProcessLineNumberValidation()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Ozone Generator")
Dim MyRange As Range: Set MyRange = ws.Range("B8:B200")
Dim MyCell As Range
Application.ScreenUpdating = False
For Each MyCell In MyRange
If MyCell > ws.Cells(3, 2) Then MyCell.ClearContents
Next MyCell
Application.ScreenUpdating = True
End Sub
this could be a work for Autofilter():
Sub ProcessLineNumberValidation()
With ThisWorkbook.Sheets("Ozone Generator").Range("B7:B200") 'reference your sheet range B7:B200 (B7 is the header, values are from B8 downwards)
.AutoFilter field:=1, Criteria1:=">" & .Parent.Range("B3").Value2 ' filter referenced range with values greatre than referenced range sheet cell B3
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents ' clear any filtered cell other than header
.Parent.AutoFilterMode = False ' remove autofilter
End With
End Sub
and if you want ProcessLineNumberValidation() being called on every "Ozone Generator" sheet B3 cell change then place this code in that sheet code pane:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$3" Then 'if cell B3 has changed
Application.EnableEvents = False ' disable events to prevent this event handler being called in a possibly infinite loop
ProcessLineNumberValidation ' process your range
Application.EnableEvents = True ' enable events back on
End If
End Sub
I am trying to write a simple thing that will merge cells in excel with the same information. What I've got thus far is what follows:
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:B1000") 'Set the range limits here
Set rngMerge2 = Range("C2:C1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
For Each cell In rngMerge2
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. Is there another way to group it.
Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. I was hoping you all could help steer me into the right direction.
Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method.
Performance
1000 seems like an arbitrary row: Range("B2:B1000"). This range should be trimmed to fit the data.
It is better to Union all the cells to be merged and merge them in a single operation.
Application.DisplayAlerts does not need to be set to True. It will reset after the subroutine has ended.
Public Sub MergeCells()
Dim Column As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each Column In .Columns("A:K")
Set Column = Intersect(.UsedRange, Column)
If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
Next
End With
Application.ScreenUpdating = True
End Sub
Sub MergeEqualValueCellsInColumn(Target As Range)
Application.DisplayAlerts = False
Dim cell As Range, rMerge As Range
For Each cell In Target
If cell.Value <> "" Then
If rMerge Is Nothing Then
Set rMerge = cell
Else
If rMerge.Cells(1).Value = cell.Value Then
Set rMerge = Union(cell, rMerge)
Else
rMerge.Merge
Set rMerge = cell
End If
End If
End If
Next
If Not rMerge Is Nothing Then rMerge.Merge
End Sub
You keep modifying the cells in rngMerge but not the definition of it before reusing it. This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows.
Option Explicit
Private Sub MergeCells()
Dim i As Long, c As Long, col As Variant
Application.DisplayAlerts = False
'Application.ScreenUpdating = false
col = Array("B", "C", "AF", "AG")
For c = LBound(col) To UBound(col)
For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
Cells(i, col(c)).Resize(2, 1).Merge
Cells(i, col(c)).HorizontalAlignment = xlCenter
Cells(i, col(c)).VerticalAlignment = xlCenter
End If
Next i
Next c
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I've added a wrapping loop that cycles through multiple columns pulled from an array.
I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells.
It appears you are running the same procedure on rngMerge and rngMerge2, and that they are the same size.
I suggest the following, where you just iterate through the columns, and then through the cells in each column:
Option Explicit
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Dim rngFull As Range
Set rngFull = Range("B2:AK1000")
For Each rngMerge In rngFull.Columns
For Each cell In rngMerge.Cells
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
'Add formatting statements as desired
End If
Next cell
Next rngMerge
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
NOTE As written, this will only handle duplicates. If you have triplets or more, only pairs of two will be combined.
I would frame the problem a bit differently. Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. I think it a bit clearer to check each cell against the previous cell value instead.
Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers).
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
Set wks = Sheets("Sheet1")
'To run this code across the entire "used part" of the worksheet, use this:
Set mergeRange = wks.UsedRange
'If you want to specify a range, you can do this:
'Set mergeRange = wks.Range("A2:AK1000")
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
'In that case, the following will return the first cell in the merge area
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub procedure:
Sub MergeCellsInRange(mergeRange As Range)
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
and call it multiple times from your main procedure:
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
Set wks = Sheets("Sheet1")
MergeRange wks.Range("A2:U1000")
MergeRange wks.Range("AA2:AK1000")
End Sub
References:
Excel object model
Global Sheets property, Sheets collection
Worksheet object
UsedRange property
Range object
Cells property
Row property
Offset property
MergeArea property
Value property
VBA
For Each ... In construct
IsEmpty function
Dim statement
Set statement
Sub statement
So I'm fairly new to VBA, and I have been struggling with trying to get my macro to work.
Essentially what I'm trying to do is have a program read down a column, and for every "X" located in that column, the corresponding hyperlink in the adjacent column will be selected.
Sub Select_Hyperlinks()
Dim rng As Range, cell As Range, sel As Range
Dim sht As Worksheet
For x = 1 To 6
Set sht = Sheets("Generator")
Set sel = cell.Offset(-1, 0)
Set rng = Intersect(sht.Range("D4:D9"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) <> "X" _
Then
If sel Is Nothing Then
Set sel = cell.Offset(-1, 0)
sel.Select
End If
Next cell
End If
Next x
End Sub
I also tried a simpler idea using the Find and FindNext functions and for each X, I tried to get it to select and activate the cell in the adjacent column, but also with no luck. It seems I always get snagged up on the .Offset function.
EDIT:
Here's what I've managed to come up with, after some further research. I've adapted this from a macro designed to delete all empty rows.
Sub AutoOpen()
Dim xlastcell As Integer
Dim xcell As Integer
xcell = 1
Range("C200").End(xlUp).Select
xlastcell = ActiveCell.Cells 'This used to say ActiveCell.Row but I want a single cell'
Do Until xcell = xlastcell
If Cells(xcell, 1).Value = "X" Then
Cells(x, 1).Select
ActiveCell.Offset(0, -1).Select 'I'm also unable to get this function to work'
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
xcell = xcell - 1
xlastcell = xlastcell - 1
End If
xcell = xcell + 1
Loop
End Sub
Are you saying that if there is an X in the one column, you want to open the hyperlink?
EDIT:
Use this and change things to match your variables.
Sub asdhkl()
Dim c As Hyperlink
Dim i As Range
For Each i In Sheets(1).Range("b1:b3")
If i = "x" Then
Set c = i.Offset(0, -1).Hyperlinks(1)
c.Follow
End If
Next i
End Sub
trying to delete rows with cells with fewer than 2 characters. range("A1") line is highlighted and i have no idea why.
i can run it without the line and for some reason it deletes everything.
any advice greatly appreciated. here's the code:
Option Explicit
Sub way()
Dim cell As Range
Range(“A1").CurrentRegion.activate
For Each cell In Selection
If Len(cell) < 2 Then Selection.EntireRow.Delete
Next cell
End Sub
You can avoid a slow loop by using AutoFilter
This code
Works out the size of the current region from A1
In the next column adds an array formula checking the length of all cells in each row, =MIN(LEN(A1:C1))<2
AutoFilter deletes the True results
code
Sub NoLoops()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Range("A1").CurrentRegion
Set rng2 = Range(Cells(1, rng1.Columns.Count + 1), Cells(rng1.Rows.Count, rng1.Columns.Count + 1))
ActiveSheet.AutoFilterMode = False
With rng2
.Formula = "=MIN(LEN(RC[-" & rng1.Columns.Count & "]:RC[-1]))<2"
.FormulaArray = .FormulaR1C1
.Value = .Value
.AutoFilter Field:=1, Criteria1:="TRUE"
.EntireRow.Delete
End With
ActiveSheet.AutoFilterMode = False
End Sub
Give this a try
Sub mysub()
Dim r As Range
Dim i As Double
Dim rcount as Double
Dim mybool As Boolean
Set r = Range("A1").CurrentRegion
i = 1
mybool = False
Do
rcount = r.Rows.count
For j = 1 To r.Columns.count
If Len(Cells(i, j).Value) < 2 Then
Rows(i).Delete
If rcount = 1 then Exit Sub
mybool = True
Exit For
End If
Next j
If mybool = False Then i = i + 1
mybool = False
Loop While i <= rcount
End Sub
Edit: just to elaborate on why I provided a new code alltogether here - the logic behind the original code is actually flawed anyway.
Consider for instance what happens if you range involves the following consecutive rows
A B C D E
1 ee e eee ee eee
2 f fff fff ff ff
Your code will explore each cell row by row top to bottom, from left to right. So in this example:
when reaching B1, it will delete row 1, and row 2 will be moved to row 1
from there, your loop will pick up from cell C1 - not A1. In other words, it will miss out on exploring the value of cell A1 which should qualify the row for deletion
Sub way()
Dim Cell As Range
For Each Cell In Range("A1").CurrentRegion
If Len(Cell) < 2 Then Cell.EntireRow.Delete
Next Cell
End Sub
#IAmDranged is correct in that when you are deleting a row, the next row will move up and become the current row. The Next cell line will then pass over this row and move to the next row without checking to see if any Cells are less than 2 characters in length.
Another method for this would be to leave the Delete method until after the Cells with fewer than 2 characters have been found:
Sub way()
Dim cell As Range
Dim deleteRange As Range 'This will be used to store the Cells found
Range("A1").CurrentRegion.Activate
For Each cell In Selection
If Len(cell) < 2 Then
If deleteRange Is Nothing Then
' If this is the first cell found, then Set deleteRange to this cell
Set deleteRange = cell
Else
' Any cells found after the first, we can use the
' Union method to add it to the deleteRange
Set deleteRange = Application.Union(cell, deleteRange)
End If
End If
Next cell
' Once all cells have been found, then Delete
deleteRange.Delete
End Sub