Here is an example of what I am trying to accomplish:
I am trying to add an "x" in the next 3 blank cells that are next to a nonblank cell (from left to right). I do not want to overwrite any cells though. As you can see in the first row, only December and January are filled and I did not overwrite February.
Any ideas?
Sub sub1()
Dim irow&, icol&, n&
For irow = 2 To 6 ' rows
n = 0
For icol = 2 To 14 ' columns
If Cells(irow, icol) = "" Then
n = n + 1
If n <= 3 Then Cells(irow, icol) = "x"
Else
n = 0
End If
Next
Next
End Sub
For Each ID In Range("A2:A6") 'Change your range according your ID
For Each cell In ID.EntireRow.Cells 'Check each cell of ID's row
If cell.Value = "" Then
cell.Value = "x"
No = No + 1
Else
No = 0 'Recount
End If
If No = 3 Then Exit For 'stop after mark 3 x
Next
Next
you could use this
Option Explicit
Sub main()
Dim cell As Range, nCols As Long
With ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
For Each cell In .Cells
nCols = WorksheetFunction.Min(cell.Column - 1, 3)
If Intersect(cell.Offset(, -nCols).Resize(, nCols + 1), .Cells).Count < 4 Then cell.Value = "x"
Next
End With
End Sub
Related
Is there a way in VBA to add a "Z" next to 3 x's within the example below? The cell must be blank after the 3 x's. (Just like the first ID and April below)
Adding to the accepted code in the answer to your previous question:
Sub sub1()
Dim irow&, icol&, n&
For irow = 2 To 6 ' rows
n = 0
For icol = 2 To 14 ' columns
If Cells(irow, icol) = "" Then
n = n + 1
If n <= 3 Then
Cells(irow, icol) = "x"
ElseIf n = 4 Then
Cells(irow, icol) = "z"
End If
Else
n = 0
End If
Next
Next
End Sub
I am very new to VBA and have been stuck on this for a few days now.
I would like to compare H2 and H3. If equal then turn the cell green , If not equal then turn the cell red.
Once this is complete I would like to do the same for H4 and H5 , then H6 and H7...... all the way down to the last row of data.
Thank you in advance for your help .
How about something like this?
Sub ForLoopTest()
Dim loop_ctr As Integer
Dim Max As Integer
Max = ActiveSheet.UsedRange.Rows.Count
For loop_ctr = 1 To Max
If loop_ctr Mod 2 = 0 Then
row_below = loop_ctr + 1
If Cells(loop_ctr, "H") = Cells(row_below, "H") then
Cells(loop_ctr, "H").Interior.ColorIndex = 4
Cells(row_below, "H").Interior.ColorIndex = 4
Else
Cells(loop_ctr, "H").Interior.ColorIndex = 3
Cells(row_below, "H").Interior.ColorIndex = 3
End If
End If
Next loop_ctr
End Sub
I still feel like conditional formatting is they way to go here so that it's reactive to values changing in the worksheet, but if you are stuck on VBA as a solution here, something like this should do the trick:
Sub greenOrRed()
Dim lngRow As Long
For lngRow = 2 To Sheet1.Range("H2").End(xlDown).Row Step 2
If Sheet1.Range("H" & lngRow).Value = Sheet1.Range("H" & lngRow + 1).Value Then
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 4
Else 'didn't match
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 3
End If
Next lngRow
End Sub
You could also use a For Each loop to walk down the column which makes for some nice to read code. You just have to apply a test for Mod 2 on the row you are analyzing instead of using the very handy STEP 2 like in the For loop above:
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then
If rngCell.Value = rngCell.Offset(1).Value Then
rngCell.Resize(2).Interior.ColorIndex = 4
Else
rngCell.Resize(2).Interior.ColorIndex = 3
End If
End If
Next rngCell
End Sub
And if you really want to condense it you can apply some boolean math to the setting of the interior.ColorIndex, but this only works because red and green are 1 colorindex value away from each other. Also the next person that adopts your code will hate you and won't think your nearly as clever as you think you are.
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then rngCell.Resize(2).Interior.ColorIndex = 3 + Abs(rngCell.Value = rngCell.Offset(1).Value)
Next rngCell
End Sub
some other ways
another loop approach:
Sub CompareCells()
Dim i As Long
With Range("H2", Cells(Rows.Count,"H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
For i = 1 To .Count Step 2 ' loop through referenced range skipping every other row
With .Cells(i, 1) ' reference current cell
.Interior.Color = IIf(.Value2 = .Offset(1).Value2, vbGreen, vbRed) 'set current cell color with respect to below cell content
End With
Next
End With
End Sub
a no-loop approach:
Sub CompareCells()
With Range("H2", Cells(Rows.Count, "H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
With .Offset(, 1) ' reference referenced range 1 column to the right offset range. this is a "helpre" column
.FormulaR1C1 = "=IF(even(row())=row(),1,"""")" ' write 1's every two rows in referenced range
With .SpecialCells(xlCellTypeFormulas, xlNumbers) ' reference referenced range "numbered" rows
.Offset(, -1).Interior.Color = vbRed ' mark referenced range 1 column left offset in red
.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,"""")" ' signal referenced range cells with 1 if corresponding 1 column to the left offset cell content equals its below cell content
.SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1).Interior.Color = vbGreen ' turn reference referenced range "numbered" cells color to green
End With
.ClearContents ' clear referenced "helper" column
End With
End With
End Sub
I have some values on column A such as:
"A" "B"
1 ok
1 ok
1 me
2 next
2 next
2 next
My code goes and and color the row on "A" if it is all the same, what i want is if column "A" have all one's to check column "B" for the last value which is "me" if it's there, leave those rows with "1" in column A alone, if it's not, delete all the rows that have "1". Not sure how to accomplish that. any help is appreciated.
Dim i As Long
Dim initialPlaceHolderValue As String
Set UsedRng = ActiveSheet.UsedRange
FirstRow = UsedRng(1).Row
LastRow = UsedRng(UsedRng.Cells.Count).Row
r = WorksheetFunction.RandBetween(180, 255)
g = WorksheetFunction.RandBetween(180, 255)
b = WorksheetFunction.RandBetween(180, 255)
initialPlaceHolderValue = Cells(FirstRow + 1, 1).Value
For i = FirstRow + 1 To LastRow
myColor = RGB(r, g, b)
If Cells(i, 1).Value = initialPlaceHolderValue Then
Debug.Print Cells(i, 19).Value
Cells(i, 1).EntireRow.Interior.Color = myColor
Else
Dim myRange As Range
initialPlaceHolderValue = Cells(i, 1).Value
r = WorksheetFunction.RandBetween(180, 255)
g = WorksheetFunction.RandBetween(180, 255)
b = WorksheetFunction.RandBetween(180, 255)
Cells(i, 1).EntireRow.Interior.Color = RGB(r, g, b)
End If
Next i
The following code should achieve what you want (at least what I think you want, your question is not very easily understandable).
Sub RemoveIfNot1AndMe()
For Each cell In Range("Your Range In Column A")
If (cell.Value = "1") Then
If (Range(cell.Address).Offset(0, 1).Value <> "me") Then
Rows(cell.Row).EntireRow.Delete
End If
End If
Next cell
End Sub
Explanations
The loop will go through every cell in your row (could be your column) and if the value is 1 it will check if the cell next to it contains me and if it doesn't delete it.
Something like
"A" "B"
1 ok
1 ok
1 me
2 next
2 next
2 next
Will end up looking like this
"A" "B"
1 ok
1 ok
2 next
2 next
2 next
EDIT
Sub RemoveIfNot1AndMe()
Dim deleteRowsWithValue1 As Boolean
deleteRowsWithValue1 = False
For Each cell In Range("Your range")
If (cell.Value = "1") Then
If (Range(cell.Address).Offset(0, 1).Value = "me") Then
deleteRowsWithValue1 = True
End If
End If
Next cell
If (deleteRowsWithValue1) Then
For i = 1 To Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
If (Range("A" & i).Value = "1") Then
Rows(i).EntireRow.Delete
i = i - 1
End If
Next
End If
End Sub
Something like
"A" "B"
1 ok
1 ok
1 me
2 next
2 next
2 next
Will end up looking like this
"A" "B"
2 next
2 next
2 next
Here is a very basic, brute force approach for you:
Find if there is such a pair of cells: "1" in A-col and "m" in B-col
If Such a pair exist then look for any row with "1" in A-col and NOT "m" in B-column; WARNING: start this at the bottom of the range and look up to the top of the worksheet (otherwise deleting rows is likely to mess up your logic). Delete any such rows.
Redo the LastRow = ... bit since it will become smaller if you deleted any lines.
Do this between the LastRow = ... line and `r = ..." line.
Good luck and share with us your success.
And, btw, it's a good practice to declare ALL the variables if you do declare them at all (as you certainly should). Also, there is no need to declare any WITHIN a loop, over and over again, as you have done there with myRange; just move it to the top of the sub.
I am trying to write in VBA a macro that searches a zero in column A, compares it to the cell in the same row but in column B, and if both are zero, and in the next row both columns are zero as well, the macro displays the first row where it found the first zero and the last consecutive row in which the last zero was.
I am currently writing it with a For each loop, searching in Column A and comparing with column B, but I have no idea on how to make it so that it continues searching until the column ends. I have to note that there could be more than one range with consecutive zeroes, therefore I imagine I need an array that stores the ranges, or at least the row numbers.
Sub BuscaMargenCero()
'
'
'
Dim ini() As Variant
Dim fin() As Variant
Dim UltimaFila As Long
Dim cell As Range
Dim i As Integer
Dim j As Integer
Dim flag As Integer
With Sheets("CĂLCULO Margen")
UltimaFila = .Range("B" & .Rows.Count).End(xlUp).Row - 1
i = 1
j = 1
flag = 0
For Each cell In Range("B2:B" & UltimaFila)
If cell = 0 And .Cells(cell.Row + 1, 6).Value = 0 Then
If flag = 0 And (.Cells(cell.Row + 1, 2).Value = 0 And .Cells(cell.Row + 1, 6).Value = 0) Then
ini(i) = cell.Row
i = i + 1
flag = 1
ElseIf flag = 1 And (.Cells(cell.Row + 1, 2).Value <> 0 Or .Cells(cell.Row + 1, 6).Value <> 0) Then
fin(j) = cell.Row
j = j + 1
flag = 0
End If
End If
Next
End With
End Sub
I am not using Range.Find since I have read it only retrieves the first value found, and I want it to continue searching for more zeroes.
EDIT: To clarify my question, here's how the application should work
A B
2 5
0 1
0 0
0 0
0 0
12 20
The output array should contain the range (in row numbers) 3 - 5
.Autofiter on zeroes for each column. The first and last or each 'set' will be the first and last of each .Area within SpecialCells(xlcelltypevisible).
.AutoFilter requires a header row.
col A col B
2 5
0 1
0 0
0 0
0 0
12 20
0 0
0 0
12 20
Module code:
Sub Macro2()
Dim a As Long, rws As Variant
With Worksheets("sheet4")
if .autofiltermode then .autofiltermode = false
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp))
.AutoFilter field:=1, Criteria1:=0
.AutoFilter field:=2, Criteria1:=0
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
With .SpecialCells(xlCellTypeVisible)
ReDim rws(1 To .Areas.Count, 1 To 2)
For a = LBound(rws, 1) To UBound(rws, 1)
With .Areas(a)
rws(a, 1) = .Cells(1).Row
rws(a, 2) = .Cells(.Cells.Count).Row
End With
Next a
End With
End If
End With
End With
if .autofiltermode then .autofiltermode = false
End With
For a = LBound(rws) To UBound(rws)
Debug.Print rws(a, 1) & " to " & rws(a, 2)
Next a
End Sub
Immediate window results:
4 to 6
8 to 9
Is there any efficient way or a correct way to copy and paste within the same worksheet? My code:
With ActiveWorkbook.Sheets("Sheet1")
For Each row In .Rows
If Not row.Columns("A:A") Is Empty Then 'error here
.Columns("A:A").Copy .Range("B1")
End If
Next rw
.Columns("A:A").Delete
End With
So in the code above, I would like to replace the column B with Column A only when the Column A of the cell is NOT empty.
For example:
1 Nil
Nil
24
4 Nil
4 Nil
12
3
7 Nil
2
Nil
8 Nil
Final result will be like this in Column B:
1
Nil
24
4
4
12
3
7
2
Nil
8
EDIT: Never mind, Solved.
With ActiveWorkbook.Sheets("Sheet1")
For rw = 1 To .Rows.Count
If (.Rows(rw).Columns("A:A").Value <> "") Then
.Rows(rw).Columns("A:A").Copy .Range("B" & rw)
End If
Next rw
.Columns("A:A").Delete
End With
With ActiveWorkbook.Sheets("Sheet1").UsedRange
For Each Row In .Rows
If Row.Cells(1, 1) <> "" Then
Row.Cells(1, 2) = Row.Cells(1, 1)
End If
Next
.Columns("A:A").Delete
End With
If you want to fire the the method when any cell from column changes use the method
Worksheet_Change, Here we are catching any change over the cell in the column J only
In this example we copy the values from the column E to G, without including the empty cells. We clear first the column G if this has any old value using this command Worksheets("Sheet1").Range("G:G").ClearContents
Private Sub Worksheet_Change(ByVal Target As Range)
idx = ActiveCell.Row
idxStr = CStr(idx)
labelIdx = "J" + idxStr
Dim ii As Long
Dim columnNumber As Long
ii = 1
columnNumber = 10
If ActiveCell.Column = columnNumber And ActiveCell.Value <> "" Then
Worksheets("Sheet1").Range("F1") = Range(labelIdx).Value
Worksheets("Sheet1").Range("G:G").ClearContents
For Each cell In Worksheets("Sheet1").Range("E:E")
If cell.Value <> "" And cell.Value <> "COLUMN LABEL" Then
Worksheets("Sheet1").Range("G" + CStr(ii)).Value = cell.Value
ii = ii + 1
End If
Next cell
End If
End Sub