I'm working with a Pivot Table and i want to hide all rows in the Grand Total column that show a total of between -1 and 1. In VBA i can hide all of those rows and it works as intended if i specify the exact range e.g ("J5:J100"), however the number of columns will change throughout the month so i need the range to be dynamic.
I'm hoping this is something really simple that I'm missing but i just can't see it.
The code in theory will locate and select the last column, make that selection a range, loop through the range hiding all rows that are of minimal value.
Any ideas?
Current code:
Sub Hide_Rows()
'
' HideRows Macro
'
' Selects Last Column of Pivot Table
With ActiveSheet.PivotTables(1).TableRange1
.Offset(1, .Columns.Count - 1).Resize(.Rows.Count - 1, 1).Select
End With
' Set variables
Dim selection As Range
Dim Cell As Range
Dim rng As Range
' Make the selection a range to run the loop through
Set rng = selection
' Loop to hide all cells between -1 & 1
For Each Cell In rng `(THIS IS WHERE THE CODE STOPS)`
If Cell.Value < 1 And Cell.Value > -1 Then
Cell.EntireRow.Hidden = True
End If
Next Cell
End Sub
Related
I'm trying to build a VBA application that checks for a certain value, then adds a row on top for each time this value is found.
Sub copy()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("B2:B10")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.value = "test" Then
MsgBox "found" + cell.Address
cell.EntireRow.Insert
End If
Next cell
Next row
End Sub
Every time I try to run this function, however, it keeps adding rows on top of each other continuously and not for each occurrence.
If you loop the cells from top to bottom, adding the row will push your original range down, causing the next loop to evaluate the previous cell.
To avoid this, loop backwards (i.e. bottom to top):
Sub copy_test()
Dim rng As Range
Set rng = Range("B2:B10")
Dim i As Long
For i = rng.Cells.Count To 1 Step -1
If rng.Cells(i).Value = "test" Then
Debug.Print "Found"
rng.Cells(i).EntireRow.Insert
End If
Next i
End Sub
Note: Set rng = Range("B2:B10") is telling VBA that you are referring to Cells B2:B10 of the ActiveSheet which might not be what you want.
Please fully qualify your range to avoid this. (e.g. ThisWorkBook.Worksheets("Sheet1").Range("B2:B10") or use the code name of the worksheet Sheet1.Range("B2:B10").)
I'm trying to make a checkbook register on excel 365. I am trying to add the feature of deleting a row(transaction) but when I run my vba code it errors out with the following: Run-time error '1004': Paste method of worksheet class failed.
When I run my code to delete a row the balance column fills up with "#REF". My effort to fix this by copying the balance column and pasting it back after the row is deleted isn't working. Balance column still fills up with "#REF"s. Here is the code i'm using to copy and paste the balance column:
Sub DeleteTransactionRectangle_Click()
Dim deletedRow
Dim rng As Range
Set rng = Selection
deletedRow = rng.Row
MsgBox (deletedRow)
Worksheets("Register").Range("I:I").Copy
rng.EntireRow.Delete
ActiveSheet.Paste Destination:=Worksheets("Register").Range("I:I")
End Sub
Anyone have any ideas to make this work.
You have dim 'rngg' but set 'rng' - should these not both be the same?
When you delete the row, it seems the copied information is lost from the clipboard. Instead, you could copy the formula from column I in the preceding row, and paste it back into the row you deleted:
rng.EntireRow.Delete
ActiveSheet.Range("I" & deletedRow - 1).Copy
ActiveSheet.Range("I" & deletedRow).Select
ActiveSheet.Paste
Deleting Rows Containing Formulas
Tip
In design mode, right-click on the command button and select Properties. Change TakeFocusOnClick to False, so when you click the command button it doesn't get selected (focus) but the selection on your sheet stays the same.
Formula
Your formula turns out to be bad when deleting rows. You could change it to:
=SUM(H$1:H2)-SUM(F$1:F2)
which is 'deleting columns proof'.
Improve Code
To Study
Range.Find
method
Areas object
Range.Areas property
Range.Resize property
Application.Union method
Application.Intersect method
Change the values in the constants section to fit your needs.
Option Explicit
Sub DeleteTransactionRectangle_Click()
Const rowFR As Long = 2 ' First Row of Data
Const colFR As Long = 9 ' Formula Column
Dim rowLR As Long ' Last Row of Data
Dim rng As Range ' Current Area (For Each Control Variable)
Dim rngTransAction As Range ' Transaction (Column) Range
Dim rngUnion As Range ' Union Range
Dim rngFinal As Range ' Intersection (Final) Range
' Calculate Last Row of Data.
rowLR = Columns(colFR).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious).Row
' From the selection, create Union Range which only contains cells
' of Formula Column, which will later be compared
' to Transaction (Column) Range.
For Each rng In Selection.Areas
If Not rngUnion Is Nothing Then
Set rngUnion = Union(rngUnion, Cells(rng.Row, colFR) _
.Resize(rng.Rows.Count))
Else
Set rngUnion = Cells(rng.Row, colFR).Resize(rng.Rows.Count)
End If
Next
' Define Transaction (Column) Range.
Set rngTransAction = Cells(rowFR, colFR).Resize(rowLR - rowFR + 1)
' Create Intersection (Final) Range which will 'eliminate'
' all 'non-valid' areas of the Selection Range. 'Non-valid' areas are
' the ones before First Row of Data and after Last Row of Data.
If Not rngUnion Is Nothing Then Set rngFinal _
= Intersect(rngUnion, rngTransAction)
' Delete rows of Intersection (Final) Range.
If Not rngFinal Is Nothing Then rngFinal.EntireRow.Delete
End Sub
I have the example where I want to write a VBA statement which will select all data in a single column, there are no blanks in the column data. The column position will never change e.g. column A, and the data starts in row 3. However the total number of rows in the column will change regularly.
I want the system to dynamically select all the cells in column and then I can run a method against these selected pieces of data.
As an example of performing an action on your range without selecting it:
Public Sub Test()
Dim rColA As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rColA = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp))
MsgBox "Column A range is " & rColA.Address 'Delete if you want.
rColA.Interior.Color = RGB(255, 0, 0) 'Turn the back colour red.
rColA.Cells(2, 1).Insert Shift:=xlDown 'Insert a blank row at second cell in range
'So will insert at A4.
'If the first cell in your range is a number then double it.
If IsNumeric(rColA.Cells(1, 1)) Then
rColA.Cells(1, 1) = rColA.Cells(1, 1) * 2
End If
End With
End Sub
Try
Dim LastRow as Long, sht as worksheet
Set sht = ThisWorkbook.Worksheets("My Sheet Name")
LastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
sht.Range("A3:A" & LastRow).Select
Like Darren Bartrup-Cook says, you may not need to select the data, you can almost always perform actions directly which is much faster.
If your column is "isolated" meaning no other nonblank cells touch your data you can use:
Range("firstCellInYourColumn").CurrentRegion.Select
(this works the same way as Ctrl+* from keyboard)
otherwise use:
Range(Range("firstCellInYourColumn"), Range("firstCellInYourColumn").End(xlDown)).Select
both will work if there are really no blanks within your data.
You should also prepend all Range with worksheet expression, I omitted this.
I am trying to set up a procedure that looks up cells in Column "G" and if a value is greater than 1, copy that entire table row, insert a row (as many times - 1 based on the value) and paste that value into each newly inserted row.
So if there is a quantity of 3 in cell "G4" then I would like to copy the row of that cell and insert a row below it 2 times and paste the copied values.
Below is what I have so far...
**Note all of this is in a table in Excel. (not sure if that's part the issue with my code)
Dim Qty As Range
For Each Qty In Range("G:G").cells
If Qty.Value > 1 Then
Qty.EntireRow.cell
Selection.Copy
ActiveCell.Offset(1).EntireRow.Insert
Selection.Paste
Selection.Font.Strikethrough = True
End If
Next
End Sub
There are a number of issues with your approach and code
You say the data is in an Excel Table. Use that to your advantage
When inserting rows into a range loop from the bottom up. This prevents the inserted rows interfering with the loop index
Don't use Selection (and even if you do your logic doesn't manipulate the ActiveCell)
Don't loop over the whole column (thats a million rows). Limit it to the table size
Here's a demonstration of these ideas
Sub Demo()
Dim sh As Worksheet
Dim lo As ListObject
Dim rColumn As Range
Dim i As Long
Dim rws As Long
Set sh = ActiveSheet ' <-- adjuct to suit
Set lo = sh.ListObjects("YourColumnName")
Set rColumn = lo.ListColumns("YourColumnName").DataBodyRange
vTable = rColumn.Value
For i = rColumn.Rows.Count To 1 Step -1
If rColumn.Cells(i, 1) > 1 Then
rws = rColumn.Cells(i, 1) - 1
With rColumn.Rows(i)
.Offset(1, 0).Resize(rws, 1).EntireRow.Insert
.EntireRow.Copy .Offset(1, 0).Resize(rws, 1).EntireRow
.Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
End With
End If
Next
End Sub
I have a list in excel with about 20000 rows and 4 columns. This excel sheet contains names in bold, and the columns after that have information about them. After each name there is some excess information that takes up either 3 or 4 rows, but it's not consistent. I need to run through the sheet and delete all the rows where there isn't a bold name.
You need to create a macro the finds out how many rows are in the current worksheet and that then iterates through the rows from the bottom of the worksheet to the top checking to see if the Font.Bold property on the first column of the row is set to false. If so you delete that row.
The following works for me:
Sub DeleteUnboldRows()
Dim lastRow As Long
Dim currentRow As Long
'Select All the rows in the active worksheet
lastRow = ActiveSheet.UsedRange.Rows.Count
' Iterate through each row from the bottom to the top.
' If we go the other way rows will get skipped as we delete unbolded rows!
For currentRow = lastRow To 1 Step -1
'Look at the cell in the first column of the current row
' if the font is not bolded delete the row
If ActiveSheet.Rows(currentRow).Columns(1).Font.Bold = False Then
ActiveSheet.Rows(currentRow).Delete
End If
Next currentRow
End Sub
Here is a reference for the Bold property: http://msdn.microsoft.com/en-us/library/office/aa224034%28v=office.11%29.aspx
Sub deleteNonBolded()
Dim cell As Range
Dim selectRange As Range
For Each cell In Intersect(ActiveSheet.Range("A:A"), ActiveSheet.UsedRange)
If (cell.Font.Bold = False) Then
If selectRange Is Nothing Then
Set selectRange = cell
Else
Set selectRange = Union(cell, selectRange)
End If
End If
Next cell
selectRange.EntireRow.Delete
End Sub