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
Related
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
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
I'm having trouble with my loop not running throughout my entire sheet 1. If the value in Sheet 1 "tests" exist in sheet 2 "cancer". Then i want the value in sheet 2 "cancer" to be placed into sheet 1 "Tests". The code works except for the loop. Currently it only applies to the first record in my first sheet then stops.
Sub Testing()
Dim x As Long
Dim y As Long
x = 2
y = 2
Do While Sheets("Cancer").Cells(y, 1).Value <> ""
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) Then
If Sheets("Tests").Cells(x, 4).Value = "" Then
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
x = x + 1
End If
End If
y = y + 1
Loop
End Sub
I would use two for loops
for y = 2 to 10000 'the range your values are found
if Sheets("Cancer").Cells(y, 1).Value <> "" then
for x = 2 to 10000 'the range your values are in
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) and Sheets("Tests").Cells(x, 4).Value = "" Then
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
End If
next
end if
next
The reason for the loop not running throughout the entire sheet 1 is because of these two lines:
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) and Sheets("Tests").Cells(x, 4).Value = ""
If these conditionals aren't both true, then x will never loop to its next iteration, and you'll have gone through looping through each value of Sheet2 "Cancer" while checking only the same record of Sheet1 "Tests".
You've almost qualified all of your ranges. You missed one. Try changing the line:
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
to
Sheets("Tests").Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
I want to copy the end of the column B and C in worksheet 1
To column B and C in worksheet 2
I have this :
and this is above :
And here is the code
'Copy of "Maintenances" in worksheet 2
n = 58 'start to look row 58
j = 2 'copy in row 2 in worksheet 2
Sheets("1").Select 'select sheet 1
Do While Cells(n, 1) <> "x" 'do for each cells untill there is a "x" in column A
If Cells(n, 1) <> "x" Then 'if column A is empty, then :
Sheets("2").Cells(j, 2) = Sheets("1").Cells(n, 2) '
Sheets("2").Cells(j, 3) = Sheets("1").Cells(n, 3) '
j = j + 1
End If 'fin du if
n = n + 1
Loop 'retourne au do while
I want to copy all row Under "maintenance" in worksheet 2, BUT the row of "maintenance" can change. the problem is not when the row is ending, but when it start. In my code, it copies column B and C between 58 and when there is a "x" in column 1. but I want that the copy start when in column B its "maintenance"
If I understand your question correctly, then you may replace n = 58 'start to look row 58 with the following code to determine the value of variable n as a start row.
Dim WordToFind As String, FirstWord As String
Dim FindWord
WordToFind = "Maintenance"
With Sheets("1").Range("A:C")
Set FindWord = .Find(what:=WordToFind, SearchDirection:=xlNext)
If Not FindWord Is Nothing Then
FirstWord = FindWord.Row
Do
n = FindWord.Row + 1 'The value of n start from the row below "Maintenance"
Exit Do
Loop While Not FindWord Is Nothing And FindWord.Row <> FirstWord
Else
MsgBox "There is no word " & WordToFind
Exit Sub
End If
End With
You can change the value WordToFind depending on a word or string you are looking for.