I have some data in sheet called New, and my data are in column A to column K. However, column E to H are intentionally left blank for data analysis purposes and I have no header so my data starts from cell A1. Now in column A we have color in cell, I would like to delete any rows that aren't white so keep rows that don't have color in it.
I did some research but all of the codes I got online either delete the whole sheet or just pass through codes and nothing happens. Below are the ones I am currently using that doesn't do anything. I use F8 and still no error.
See image for my sample data and I am trying to get the results with cells that don't have any color in it. I tried to remove quotation mark for the color index but still it doesn't work.
Sub deleterow()
lastRow = Worksheets("New").Cells(Rows.Count, "A").End(xlUp).Row
For i = lastRow To 1 Step -1
If Worksheets("New").Cells(i, 1).Interior.ColorIndex <> "2" Then
Rows(i).EntireRow.Delete
i = i + 1
End If
Next I
End Sub
Try the code below:
Option Explicit
Sub deleterow()
Dim i As Long, LastRow As Long
With Worksheets("New")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
'If .Cells(i, 1).Interior.Color <> xlNone Then
' replace RGB(255, 255, 255) with the "white" color
If .Cells(i, 1).Interior.Color <> RGB(255, 255, 255) Then
.Rows(i).Delete
End If
Next i
End With
End Sub
Delete No Color Row
Union Version
Option Explicit
Sub DeleteNoColorRow()
Const cSheet As Variant = "Sheet1" ' Worksheet Name/Index
Const cFirstR As Integer = 1 ' First Row
Const cColumn As Variant = "A" ' Column Letter/Number
Dim rngU As Range ' Union Range
Dim lastRow As Long ' Last Row
Dim i As Long ' Row Counter
With ThisWorkbook.Worksheets(cSheet)
lastRow = .Cells(.Rows.Count, cColumn).End(xlUp).Row
For i = cFirstR To lastRow
If .Cells(i, cColumn).Interior.ColorIndex <> xlNone Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, cColumn))
Else
Set rngU = .Cells(i, cColumn)
End If
End If
Next
End With
If Not rngU Is Nothing Then
rngU.EntireRow.Delete ' Hidden = True
Set rngU = Nothing
End If
End Sub
Related
I'm using this code to check if the cell is a number or not to delete it, but there are 3 columns that I have to do this. But Do Until only goes through it once and stops doing it, leaving the loop.. it changes the col to 5 or 8 as it is in the for
Could someone help me with what I'm doing wrong in this code?
Another problem I have encountered is that if the cell is empty, vba fills in 0 as a value, is there a way to leave the cell blank instead of putting 0?
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 1
For Col = 2 To 8 Step 3
Do Until Cells(Row, 1).Value = ""
If IsNumeric(Cells(Row, Col)) = False Then
Cells(Row, Col).Clear
Else
Cells(Row, Col).Select
If Cells(Row, Col).Value = 0 Then
Cells(Row, Col).Value = (Cells(Row, Col).Value) * 1
Cells(Row, Col).NumberFormat = "$ #,##0.00"
Else
Cells(Row, Col).Value = CDec((Cells(Row, Col).Value))
Cells(Row, Col).NumberFormat = "$ #,##0.00"
End If
End If
Row = Row + 1
Loop
Next
End Sub
You can loop through the columns, but use special cells to determine if it is text or a number.
Based on your comment, it is either text or numbers, not sure why you would need to times by 1, or make value=value.
Sub UsingSpecialCells()
Dim ws As Worksheet
Dim rng As Range, LstRw As Long
Set ws = ActiveSheet
With ws
For Col = 2 To 8 Step 3
LstRw = .Cells(.Rows.Count, Col).End(xlUp).Row
Set rng = .Range(.Cells(2, Col), .Cells(LstRw, Col))
On Error Resume Next
rng.SpecialCells(xlCellTypeConstants, 2).ClearContents
On Error GoTo 0
On Error Resume Next
rng.SpecialCells(xlCellTypeConstants, 21).NumberFormat = "$#,##0.00"
On Error GoTo 0
Next
End With
End Sub
Clean Data: Apply Consistent Formatting in Columns
Option Explicit
Sub UpdateCurrency()
' Define constants.
Const FIRST_ROW As Long = 2 ' adjust: you have headers, right?
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Hard to believe that you know the column numbers but not the worksheet name.
' Calculate the last row, the row of the bottom-most non-empty cell
' in the worksheet.
Dim lCell As Range
Set lCell = ws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data
Dim LastRow As Long: LastRow = lCell.Row
Dim crg As Range, cell As Range, cValue, Col As Long
For Col = 2 To 8 Step 3 ' to not introduce further complications
' Reference the single-column range from the first to the last row.
Set crg = ws.Range(ws.Cells(FIRST_ROW, Col), ws.Cells(LastRow, Col))
' Clear the undesired values (all except empty and numeric values).
For Each cell In crg.Cells
' Write the cell value to a variant variable.
cValue = cell.Value
' Check if the value is not numeric.
If Not IsNumeric(cValue) Then cell.ClearContents
Next cell
' Apply the formatting to the whole column range so it takes effect
' if you decide to add numbers to the empty cells.
crg.NumberFormat = "$ #,##0.00" ' "\$ #,##0.00" if $ is not native
' Copy the values to memory, and copy them back to the range
' for the formatting to affect the remaining numerics
' (numbers and numbers formatted as text).
crg.Value = crg.Value
Next Col
MsgBox "Currency updated.", vbInformation
End Sub
Once iteration through the column 2 last row value is complete, blank row gets iterated and as per the condition Cells(Row, 1).Value = "" gets true and terminates the do until loop.
I have made small changes to your code and created the perfect working solution.
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 1
Dim row_i As Integer
row_i = Cells(1, 2).End(xlDown).Row
For Col = 2 To 8 Step 3
Row = 1
Do Until Row > row_i
If IsNumeric(Cells(Row, Col).Value) = False Then
Cells(Row, Col).Clear
Else
Cells(Row, Col).Select
If Cells(Row, Col).Value = 0 Then
Cells(Row, Col).Value = (Cells(Row, Col).Value) * 1
Cells(Row, Col).NumberFormat = "$ #,##0.00"
Else
Cells(Row, Col).Value = CDec((Cells(Row, Col).Value))
Cells(Row, Col).NumberFormat = "$ #,##0.00"
End If
End If
Row = Row + 1
Loop
Next
End Sub
I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub
I have a formatting macro below:
Sub Colour_whole_sheet()
Dim lastRow As Long
Dim lastColumn As Long
lastRow = Range("A1").End(xlDown).Row
lastColumn = Range("A3").End(xlToRight).Column
'Colour alternate rows purple / white
For Each cell In Range(Cells(1, 1), Cells(lastRow, lastColumn))
If cell.Row Mod 2 = 1 Then
cell.Interior.Color = RGB(242, 230, 255)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next cell
End Sub
It doesn't run when I call it from another macro, which is just:
Sub Run_macros()
[A bunch of other subs]
Call Colour_whole_sheet
[A bunch of other subs]
End Sub
It doesn't come up with an error - it just doesn't do anything. But when I select it specifically on its own, from View > Macros > View Macros > Run, it works fine.
Do you know why this might be?
EDIT:
Sub Colour_whole_sheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Calendar")
Dim lastRow As Long
Dim lastColumn As Long
lastRow = ws.Range("A1").End(xlDown).Row
lastColumn = ws.Range("A3").End(xlToRight).Column
'Colour alternate rows purple / white
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
If cell.Row Mod 2 = 1 Then
cell.Interior.Color = RGB(242, 230, 255)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next cell
End Sub
you might be after this revision of your code
Sub Colour_whole_sheet(Optional sht As Variant)
If IsMissing(sht) Then Set sht = ActiveSheet ' if no argument is passed assume ActiveSheet
Dim lastRow As Long
Dim lastColumn As Long
Dim i As Long
With sht ' reference passed/assumed sheet object
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' best way to get a column last used cell row index
lastColumn = .Cells(3, .Columns.Count).End(xlToLeft).Column ' best way to get a row last used cell column index
'Colour alternate rows purple / white
With .Range("A1", Cells(lastRow, lastColumn)) ' reference all your range
.Interior.Color = vbWhite ' color it white
For i = 1 To .Rows.Count Step 2 ' loop through referenced range uneven rows
.Rows(i).Interior.Color = RGB(242, 230, 255) ' color them with purple
Next
End With
End With
End Sub
as you can see:
it always references some sheet(be it passed through sub argument or be it the active one)
it doesn't loop through all cells, but just through uneven rows
Here Range("A1") is not specified in which worksheet this range is. Always specify a worksheet for all your Range(), Cells(), Rows() and Columns() objects.
Otherwise it is very likely that your code runs on the wrong worksheet. Note that this is applicable to all your macros (not just this one). Check if you have specified a worksheet everywhere, or your code might randomly work or fail.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'your sheet name here
Then adjust the following lines:
lastRow = ws.Range("A1").End(xlDown).Row
lastColumn = ws.Range("A3").End(xlToRight).Column
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
Also note that you can format an Excel table to get rows alternated colored.
Additional notes:
The method you used is not reliable in finding the last used row/column. Better do it the other way round. Start in the very last row and go xlUp.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last used row
lastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column 'last used column in row 3
Also you don't need to go through all cells. Looping throug rows would do.
Dim i As Long
For i = 1 To lastRow
If i Mod 2 = 1 Then
ws.Rows(i).Interior.Color = RGB(242, 230, 255)
Else
ws.Rows(i)..Interior.Color = RGB(255, 255, 255)
End If
Next i
or if you don't want to color the whole row but only up to the last used column
ws.Cells(i, lastColumn).Interior.Color
Note that coloring each row on on its own can slow down a lot if there are many rows. Therefore I suggest to collect all even/uneven rows in a reference and color it at once.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last used row
lastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column 'last used
Dim EvenRows As Range
Dim OddRows As Range
Dim i As Long
For i = 1 To lastRow
If i Mod 2 = 1 Then
If OddRows Is Nothing Then
Set OddRows = ws.Rows(i)
Else
Set OddRows = Union(OddROws, ws.Rows(i))
End If
Else
If EvenRows Is Nothing Then
Set EvenRows = ws.Rows(i)
Else
Set EvenRows = Union(EvenRows, ws.Rows(i))
End If
End If
Next i
If Not OddRows Is Nothing Then OddRows.Interior.Color = RGB(242, 230, 255)
If Not EvenRows Is Nothing Then EvenRows.Interior.Color = RGB(255, 255, 255)
I am new to VBA and am trying to delete everything outside of the specified print area for every worksheet in my file. I have code that is working alright, but for some tabs, the print area begins in column B, and I need to delete column A because it is not in the print area. I cannot figure out how to rewrite my code to ensure that the column to the left of the specified print area will get deleted.
Dim FirstEmptyRow As Long
Dim FirstEmptyCol As Integer
Dim rng As Range
With ActiveSheet.PageSetup
If .PrintArea = "" Then
Set rng = ActiveSheet.UsedRange
Else
Set rng = ActiveSheet.Range(.PrintArea)
End If
End With
FirstEmptyCol = rng.Cells(rng.Cells.Count).Column + 1
FirstEmptyRow = rng.Rows.Count + rng.Cells(1).Row
Range(Cells(1, FirstEmptyCol), Cells(1, 256)).EntireColumn.Delete
Range(Cells(FirstEmptyRow, 1), Cells(Rows.Count, 1)).EntireRow.Delete
Try adding this additional code:
If rng.Column > 1 Then
Range(Cells(1, 1), Cells(1, rng.Column - 1)).EntireColumn.Delete
End If
You could try this. Find the PrintAreaand then using Intersect you could loop through the cells and find which cells are not in the PrintArea, Union the cells and then delete them at the end. Doing it this way you can delete everything that's not a part of the PrintArea, all at the same time. Hope this helps:
Sub testPrintArea()
Dim printAreaRange As Range
With ActiveSheet.PageSetup
If .PrintArea = "" Then
Set printAreaRange = ActiveSheet.UsedRange
Else
Set printAreaRange = ActiveSheet.Range(.PrintArea)
End If
End With
' Get non print area cells and union them
Dim nonPrintAreaCells As Range
Dim cell As Range
For Each cell In ActiveSheet.UsedRange
If Intersect(cell, printAreaRange) Is Nothing Then
If nonPrintAreaCells Is Nothing Then
Set nonPrintAreaCells = cell
Else
Set nonPrintAreaCells = Union(nonPrintAreaCells, cell)
End If
End If
Next cell
' do whatever...
nonPrintAreaCells.Value = ""
End Sub
You can use the Column and Row properties of a range to determine where it starts, like this
Sub DeleteOutsidePrintArea(ws As Worksheet)
Dim rng As Range
With ws
If .PageSetup.PrintArea = vbNullString Then
Set rng = .UsedRange
Else
Set rng = .Range(.PageSetup.PrintArea)
End If
' Delete columns to left, if any
If rng.Column > 1 Then
.Columns(1).Resize(, rng.Column - 1).Delete
End If
' Delete rows above, if any
If rng.Row > 1 Then
.Rows(1).Resize(rng.Row - 1).Delete
End If
' Delete columns to right, if any
If rng.Columns.Count < (.UsedRange.Columns.Count + .UsedRange.Column - 1) Then
.Columns(rng.Columns.Count + 1).Resize(, .UsedRange.Columns.Count + .UsedRange.Column - 1 - rng.Columns.Count).Delete
End If
' Delete rows below, if any
If rng.Rows.Count < (.UsedRange.Rows.Count + .UsedRange.Row - 1) Then
.Rows(rng.Rows.Count + 1).Resize(.UsedRange.Rows.Count + .UsedRange.Row - 1 - rng.Rows.Count).Delete
End If
End With
End Sub
Call it like this
Sub Demo()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook '<~~~ Adjust to suit
For Each ws In wb.Worksheets
DeleteOutsidePrintArea ws
Next
End Sub
This is really simple but I'm new to VBA.
I want to format cells in column J and K (haven't gotten to K yet) with a grey fill and border around if cells in column B is not empty. I want to do this in every worksheet in the workbook.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Format_ForecastingTemplate(ws)
Next
End Sub
Sub Format_ForecastingTemplate(ws As Worksheet)
Dim cell As Range
Dim N As Long
Dim i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
If cell <> "" Then
With ActiveSheet.Range(Cells("J"), cell.Row)
.ThemeColor = xlThemeColorDark1
.BorderAround LineStyle:=xlContinuous
End With
End If
Next
End Sub
The line that is giving me an error is If cell <> "" Then. I think it's because I'm not referencing the cell variable in column B?
Error is: Object variable or With block variable not set
Like this:
I changed it to a single macro and made changes to your original code
Sub Format_ForecastingTemplate()
Dim cell As Range
Dim N As Long
Dim i As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
'Looks at B to check if empty
If ws.Cells(i, 2).Value <> "" Then
'changes cells J to color and border
ws.Cells(i, 10).Borders.LineStyle = xlContinuous
ws.Cells(i, 10).Interior.ThemeColor = xlThemeColorDark1
ws.Cells(i, 10).Interior.TintAndShade = -0.25
End If
Next i
Next ws
End Sub
You can either change the column number or add new lines for column K
Hope this helps and please be kind and leave feedback. :)