I have been trying to remove/hide cells which values are equal to zero (0).
Sub HideRows()
Dim cell As Range, rng As Range
Cells.Rows.Hidden = False
On Error Resume Next
Set rng = Columns(5).SpecialCells(xlConstants, xlNumbers)
On Error GoTo 0
For Each cell In rng
If cell.Value = 0 Then
cell.EntireRow.Hidden = True
End If
Next
End Sub
The code removes the entire row. I want to remove the description of the value and the value.
This code will quickly clear (erase) values and comments from cells in column E that have a value of 0
Sub Testme()
Dim rng1 As Range
Set rng1 = Columns(5)
With rng1
.AutoFilter 1, "0"
With rng1.Offset
.ClearContents
.ClearComments
End With
With rng1.Offset(0, -1)
.ClearContents
.ClearComments
End With
End With
End Sub
Related
I was writing a program for deleting a row in a Selection with Empty Cell. I wrote the code and it worked well but it have a deficiency.
Code Is:
Dim i As Integer
Dim j As Integer
Dim Num As Integer
Num = Selection.Cells.Count
'MsgBox ("Num of Cells " & Num)
Selection.End(xlUp).Select
If (IsEmpty(ActiveCell)) Then
Selection.End(xlDown).Select
End If
For i = 1 To Num
If (IsEmpty(ActiveCell)) Then
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(-1, 0).EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Num = Num - 1
On Error GoTo Last
Else
ActiveCell.Offset(1, 0).Select
End If
Next
Last:
Exit
Now I was trying to rewrite the code with looping the cell in Range instead of above For loop:
Dim i As Integer
Dim j As Integer
Dim Num As Integer
Dim myRange As Range
ActiveSheet.Select
Set myRange = Selection.Cells
For Each myRange In Selection
If (IsEmpty(myRange)) Then
ActiveCell.EntireRow.Delete
On Error GoTo Last
Else
'ActiveCell.Offset(1, 0).Select
End If
Next myRange
Last:
Exit
This piece of code is not working Properly. Kindly put your Suggestions and rectify the Code
you could try
If WorksheetFunction.CountBlank(Selection) > 0 Then Intersect(Selection.SpecialCells(xlCellTypeBlanks).EntireRow, Selection.Columns(1)).EntireRow.Delete
Speciealcells seems to be easy to use.
Sub test()
Dim rngDB As Range
Set rngDB = Selection
On Error Resume Next
Set rngDB = rngDB.SpecialCells(xlCellTypeBlanks)
If Err.Number = 0 Then
rngDB.EntireRow.Delete
End If
End Sub
Here is an option that avoids relying on Selection and Select.
You can use a InputBox to determine the range. This will allow you to properly qualify all of your ranges/worksheets. You can then loop through the selected range and determine if the rows should be deleted (if blank).
At the end, delete all the rows at once. On larger operations, this will be much faster since you will only have 1 instance of deletion rather continuously deleting rows in the loop.
Option Explicit
Sub Blanks()
Dim MyRange As Range, MyCell As Range, DeleteMe As Range
Set MyRange = Application.InputBox("Select Range", Type:=8)
For Each MyCell In MyRange
If MyCell = "" Then
If DeleteMe Is Nothing Then
Set DeleteMe = MyCell
Else
Set DeleteMe = Union(DeleteMe, MyCell)
End If
End If
Next MyCell
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub
I have this working code that gets the value from "sheet1" column C to set it as sheet name and make a new worksheet and copies the "testscript" sheet.
My problem is I only need to copy that has the column value with "Y".
Here is my code:
Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet
For Each rcell In Range("C2:C500")
If rcell.Value <> "" Then
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(rcell) Then
MsgBox "This sheet already exists!"
Exit Sub
End If
Next
Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
Next rcell
Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet
For Each rcell In Range("C2:C500")
'if rcell has value and same row column J is equal to "Y"
If rcell.Value <> "" And Sheets("Sheet1").Cells(rcell.Row, 10).Value = "Y" Then
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(rcell) Then
MsgBox "This sheet already exists!"
Exit Sub
End If
Next
Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
Next rcell
I'd go as follows
Option Explicit
Sub main()
Dim rcell As Range
With Sheets("Sheet1") ' reference your "source" sheet for subsequent range explicit qualification
For Each rcell In .Range("C2:C500").SpecialCells(xlCellTypeConstants) ' loop through wanted range not empty cells with "constant" (i.e. not formulas) values
If UCase(.Cells(rcell.Row, 10)).Value = "Y" Then ' check current cell row column J value
If Not IsSheetThere(rcell.Value) Then 'check there's no sheet named after current cell value
Sheets("TestScript").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
End If
Next
End With
End Sub
Function IsSheetThere(shtName As String) As Boolean
On Error Resume Next 'avoid any error at following line to stop the routine
IsSheetThere = Worksheets(shtName).Name = shtName 'try getting a sheet with the passed name. this will throw an error if no sheet is found with that name
End Function
I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub
This is my code which does not seem to work. I basically get an "object required" error in the 3rd line "for each cell in UsedRange.Cells"
Sub AgreeAll()
Dim myRange As Range
For Each cell In UsedRange.Cells
If cell.Interior.Color = RGB(255, 192, 0) Then
If myRange Is Nothing Then
Set myRange = cell
Else
Set myRange = Union(myRange, cell)
End If
End If
Next
If Not myRange Is Nothing Then
myRange.Interior.Color = RGB(255, 255, 255)
Range("P7").ClearContents
Columns("E:F").EntireColumn.Delete
End If
End Sub
The anatomy of a basic If block:
If [condition] = [true | false] Then
'// Do something
[Else]
['// Do something Else]
End If
So in your case, you would want something like:
(Revised after comment feedback)
Dim myRange As Range
For Each cell In UsedRange.Cells
If cell.Interior.ColorIndex = 44 Then
If myRange Is Nothing Then
Set myRange = cell
Else
Set myRange = Union(myRange, cell)
End If
End If
Next
If Not myRange Is Nothing Then
myRange.Interior.ColorIndex = xlNone
Range("P7").ClearContents
Columns("E:F").EntireColumn.Delete
End If
It has never been determined whether the cells are orange filled by manually setting a background fill or whether they are filled by a conditional formatting rule. If the latter, then you can set the Interior.Pattern property to white or xlNone all you like; the CF rule will override anything you set. You can clear the content (which I assume drives the CF rule) or delete the CF rule from that cell.
The AutoFilter method can filter for the Range.DisplayFormat property. The .DisplayFormat includes both regular formatting and conditional formatting; i.e. if you see orange, then so does .DisplayFormat.
Sub AgreeAll()
Dim rng As Range
Dim c As Long
'Application.ScreenUpdating = False
With Worksheets("Sheet2") '<~~set this worksheet reference properly!
'why wait until the end to do this? It only means you have to process rtwo columns you plan to delete
.Columns("E:F").EntireColumn.Delete
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
For c = 1 To .Columns.Count
With .Columns(c)
.AutoFilter Field:=1, Criteria1:=RGB(255, 192, 0), _
Operator:=xlFilterCellColor
If .Cells.SpecialCells(xlCellTypeVisible).Count > 1 Then
.Offset(1, 0).Interior.Pattern = xlNone
For Each rng In .SpecialCells(xlCellTypeVisible)
If rng.DisplayFormat.Interior.Color = RGB(255, 192, 0) Then _
rng.FormatConditions.Delete
Next rng
'your code cleared P7; did you want to clear all of the orange cells?
'.Offset(1, 0).ClearContents
End If
.AutoFilter
End With
Next c
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Neither your code nor narrative adequately explains what Range("P7").ClearContents was supposed to do. If you wanted to clear the orange cells then I've left some commented code in the appropriate place to do that.
If you run into problems, feel free to leave a comment but remember to provide sufficient information that I can help you with it.
Try this :
Sub AgreeAll()
Dim wS As Worksheet, _
myRange As Range, _
aCell As Range
Set wS = ActiveSheet
'set ws =sheets("Your_Sheet's_Name")
With wS
For Each aCell In .UsedRange.Cells
If aCell.Interior.Color = RGB(255, 192, 0) Then
If myRange Is Nothing Then
Set myRange = aCell
Else
Set myRange = Union(myRange, aCell)
End If
End If
Next
If Not myRange Is Nothing Then
myRange.Interior.Pattern = xlNone
.Range("P7").ClearContents
.Columns("E:F").EntireColumn.Delete
End If
End With
End Sub
I am trying to delete all rows with in the range of A7:AI300 that contain a cell with yellow fill (Color index 6) I have some code that will delete all rows that contain the color but the problem I am having is that it is trying to run the code for the whole worksheet and will freeze my workbook. I am trying to insert a range to speed up the calculations. Can anyone show me how to insert the range so it works
Sub deleterow()
Dim cell As Range
For Each cell In Selection
If cell.Interior.ColorIndex = 6 Then
cell.EntireRow.Delete
End If
Next cell
End Sub
Is this what you are trying? Notice that we are not deleting each row inside the loop but creating our final "Delete Range" This will ensure that your code runs faster.
EDIT: If you are looking at range "A7:A300" then use this code
Sub deleterow()
Dim cell As Range, DelRange As Range
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A7:A300")
If cell.Interior.ColorIndex = 6 Then
If DelRange Is Nothing Then
Set DelRange = cell
Else
Set DelRange = Union(DelRange, cell)
End If
End If
Next cell
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
End Sub
And if you are looking at range "A7:AI300" then I guess this is what you want.
Sub deleterow()
Dim cell As Range, DelRange As Range
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A7:AI300")
If cell.Interior.ColorIndex = 6 Then
If DelRange Is Nothing Then
Set DelRange = cell
Else
Set DelRange = Union(DelRange, cell)
End If
End If
Next cell
If Not DelRange Is Nothing Then DelRange.Delete
End Sub
MORE FOLLOWUP
I think I might have finally understood what you are trying to achieve...
Sub deleterow()
Dim i As Long, j As Long
Dim delRange As Range
With ThisWorkbook.Sheets("Sheet1")
For i = 7 To 300 '<~~ Row 7 to 300
For j = 1 To 35 <~~ Col A to AI
If .Cells(i, j).Interior.ColorIndex = 6 Then
If delRange Is Nothing Then
Set delRange = .Cells(i, j)
Else
Set delRange = Union(delRange, .Cells(i, j))
End If
Exit For
End If
Next j
Next i
End With
If Not delRange Is Nothing Then delRange.EntireRow.Delete
End Sub
Here is what you can do. Put calculations on manual mode. Set the range you need to delete, instead of selecting...
Sub deleterow()
Dim myRange as Range
Dim cell As Range
Application.Calculation = xlCalculationManual
Set myRange = Worksheets(1).Range("A1:A300") '-- just column A would do
For Each cell In myRange
If cell.Interior.ColorIndex = 6 Then
cell.EntireRow.Delete
End If
Next cell
Application.Calculation = xlCalculationAutomatic
End Sub