My VBA code below is not looping. Kindly help
Public Sub FunWithLoops()
' Create a loop using Do while loop.
'The aim is to go through a list of numbers down a row, highlight them with a different color if greater than 10.
Dim i As Integer
i = 1
Do While i <= 10
If ActiveCell.Value > 10 Then
ActiveCell.Interior.Color = RGB(255, 0, 0)
'interior changes the background color
End If
ActiveCell.Offset(1, 0).Select
i = i + 10
Loop
End Sub
Just correcting your code without making too many changes you might not be ready to go for:
Public Sub FunWithLoops()
' Create a loop using Do while loop.
'The aim is to go through a list of numbers down a row, highlight them with a different color if greater than 10.
Dim i As Integer
i = 1
Do While i <= 10
If ActiveCell.Value > 10 Then ActiveCell.Interior.Color = RGB(255, 0, 0)
ActiveCell.Offset(1, 0).Select
i = i + 1 ' change this to + "1" not + "10"
Loop
End Sub
Please note that your ActiveCell must always be set BEFORE you run the routine, because there's nothing in the routine to set the ActiveCell first, like a line:
Range("A2").Select
You are checking the value of i against the static value of 10. You then increment i by 10. So the loop executes once, always. You essentially don't have a loop and just some extraneous code as is.
I generally would use a For Loop do go down the rows, as its made for incrementing at set intervals.
Sub FunWithForLoops()
Dim i As Long
Dim lr As Long
With ActiveSheet
lr = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find the last row in Column A
For i = 1 To lr
If .Cells(i, 1).Value > 10 Then 'Test Column A, Row i
.Cells(i, 1).Interior.Color = vbRed 'Modify Column A, Row i
End If
Next i
End With
End Sub
You can do it with a While as well, you just need to increment yourself.
Sub FunWithWhileLoops()
Dim i As Long
Dim lr As Long
With ActiveSheet
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= lr
If .Cells(i, 1).Value > 10 Then
.Cells(i, 1).Interior.Color = vbRed
End If
i = i + 1
Loop
End With
End Sub
Related
My worksheet contains blank rows which I want to keep.
However it also contains groups of two blank rows and I want to keep one of them but delete/remove the other one.
END RESULT: sheet contains only single blank rows.
First attachment shows before (highlighted where two blank rows) and second attachment shows desired final result (worksheet only contains single blank rows).
What is the VBA code to achieve this please?
Something like:
select all
identify where two blank rows are and delete one of those rows
Thanks in advance!
In an attempt to improve the question and show my efforts with my own VBA code.... this is what I had got starting with a variable counter of 0 and when it gets to 2 it would delete a row, it sort of works as in it finds and deletes the desired row but it appears to run an infinite loop :(
Sub EmptyRows()
Dim x As Integer
Dim row As Integer
NumRows = ActiveSheet.UsedRange.Rows.Count
' Select cell A2.
Range("A2").Select
row = 0
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
If Application.CountA(ActiveCell.EntireRow) = 0 Then
row = row + 1
End If
ActiveCell.Offset(1, 0).Select
If Application.CountA(ActiveCell.EntireRow) = 0 Then
row = row + 1
End If
If row >= 2 Then
MsgBox "2 Rows!"
ActiveCell.EntireRow.Delete
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
row = 0
Next
End Sub
Try the next code, please. It will check if really whole analyzed rows are empty:
Sub deleteSecondBlankRow()
Dim sh As Worksheet, arr, rngDel As Range, lastR As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
If WorksheetFunction.CountA(rows(i + 1)) = 0 Then
If arr(i + 1, 1) = "" Then
If WorksheetFunction.CountA(rows(i + 2)) = 0 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i + 2)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i + 2))
End If
End If
End If
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Select
End Sub
The code only selects the rows to be deleted. If you check it and what selected is convenient, you should only replace Select with Delete on the last code line...
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 am trying to do a "for each" sub in VBA, comparing two pairs of rows and the values in each cell to one another. For example row 2 is compared with row 3, row 4 is compared with row 5 etc. I need the code to highlight the differences in each cell for each of the comparisons. This is what I have so far and I cannot seem to get it to work. Any thought?
Sub testing_2()
Dim rw_2 As Range, rw_1 As Range, decisions As String
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
For Each rw_1 In Worksheets("worksheet").Rows
For Each rw_2 In Worksheets("worksheet").Rows
If Not StrComp(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1, vbBinaryCompare) = 0 Then
Range(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1).Interior.ColorIndex = 6
End If
Next rw_2
Next rw_1
Else: End If
End Sub
Thank you!
Basically, I am looking at each row, two at a time, and highlighting the different values between them.
One loop to to loop the rows stepping 2 rows at a time and another loop to loop the columns
Sub testing_2()
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
With Worksheets("Sheet4") ' change to your sheet
Dim lstRw As Long
lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim lstClm As Long
lstClm = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 2 To lstRw Step 2
Dim j As Long
For j = 2 To lstClm
If .Cells(i, j) <> .Cells(i + 1, j) Then
.Range(.Cells(i, j), .Cells(i + 1, j)).Interior.ColorIndex = 6
End If
Next j
Next i
End With
End If
End Sub
I want to delete negative values in a range in excel. I have a code that deletes but not all the values.
I got to know that I should first change the value to numeric type. I have the below code in which I have tried to do so with cDec and Convert.ToInt32 but not successful. I am new to vba, I don't know much about its data types. Your help will be highly appreciable:
Sub Button1_Click()
Dim ws As Worksheet
Dim i As Integer
i = 1
Set ws = Sheets("Recovered_Sheet1")
ws.Activate
Dim r As Excel.Range
For Each r In Range("A1:A250").Rows
If Not IsEmpty(ActiveCell.Value) Then
'move to the row below
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = CDec(ActiveCell.Value)
End If
Next r
Do While Cells(i, 1).Value <> ""
If Cells(i, 1) < 0 Then
Cells(i, 1).EntireRow.Delete
End If
i = i + 1
Loop
End Sub
Here is one way of doing that. Note that when deleting rows, you should work from the bottom up. Also, you don't need to change the Excel data type before running this macro, unless you have some other reason to do so (in which case there are more efficient methods than going cell by cell).
Edit Since text and blanks will return False with .Value < 0, there's no need to test anything else.
Option Explicit
Sub DelNegNumRows()
Dim I As Long
For I = 250 To 1 Step -1
With Cells(I, 1)
If .Value < 0 Then
.EntireRow.Delete
End If
End With
Next I
End Sub
Depending on the characteristics of your range, you may not need to check all 250 rows (although if that is the size of your database, you won't perceive a speed advantage to making the range smaller). For example, if all of your rows with data are non-blank, you can do something like:
lastrow = cells(1,1).end(xldown).row
or, if there might be blanks, and you want to find the last row in column A that has any data, something like:
lastrow = cells(rows.Count,1).end(xlup).row
You could then cycle, in the macro above:
for I = lastrow to 1 step -1
Sub Button1_Click()
Dim I As Long
Dim lastrow As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For I = lastrow To 1 Step -1
With Cells(I, 2)
If .Value < 0 Then
.EntireRow.Delete
End If
End With
Next I
End Sub
I am trying to loop down the column "Q" on my active sheet, find values that are in between 27 and 40 and then copy that cell along with a region around the cell noted by the (-1, -16) into a new sheet.
Right now I am just making the region bold to make sure that my loop is catching the right values and regions.
I"m new to VBA so if anyone can give me some pointers or advise on how to solve my problem I'd be very appreciative.
Sub Test2()
Application.ScreenUpdating = False
ActiveSheet.Range("Q13").Select
Let x = 0
Do While x < 500
If ActiveCell.Value >= 27 And ActiveCell.Value <= 40 Then
Range(ActiveCell, ActiveCell.Offset(-1, -16)).Select
Selection.Font.Bold = True
ActiveCell.Offset(2, 16).Activate
Else
ActiveCell.Offset(1, 0).Select
End If
x = x + 1
Loop
End Sub
Try below code :
Always set the ScreenUpdating property back to True when your macro
ends.Check this link
Avoid using Select/Activate in your code. Check this link
Always explicitly specify the sheet when working with more than one
sheet.
Avoid using ActiveCell,ActiveSheet and refer to them explicitly.
Sub Test2()
Application.ScreenUpdating = False
Dim lastRow As Long
lastRow = Sheets("sheet1").Range("Q" & Rows.Count).End(xlUp).Row
Dim rng As Range, cell As Range
Set rng = Sheets("sheet1").Range("Q1:Q" & lastRow)
For Each cell In rng
If cell.Value >= 27 And cell.Value <= 40 Then
Sheets("sheet1").Range(cell, cell.Offset(0, -16)).Copy Sheets("sheet2").Cells(Sheets("sheet2").Range("Q" & Rows.Count).End(xlUp).Row + 1, 1)
End If
Next
Application.ScreenUpdating = True
End Sub