VBA Loop for and do while - excel

I am trying to create a For and Do while loop in VBA. I want that when the value 'X' is entered in column A and if column W is equal to "T", all the rows below (column A) should be checked "X" until the next value "T" in column W.
My script does not work, only the row below is filled with "X" and the file closes (bug!)
Here is the complete code
Sub Chaine()
For Each Cell In Range("A2:A3558")
If UCase(Cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While Cell.Offset(0, 23) <> "T"
Cell.Offset(1, 0).Value = "X"
Loop
End If
Next Cell
End Sub

Try this:
Sub Chaine()
Dim c As Range, vW, flag As Boolean
For Each c In ActiveSheet.Range("A2:A3558").Cells
vW = UCase(c.EntireRow.Columns("W").value)
If UCase(c.value) = "X" And vW = "T" Then
flag = True 'insert "X" beginning on next row...
Else
If vW = "T" Then flag = False 'stop adding "X"
If flag Then c.value = "X"
End If
Next c
End Sub

Your Do While loop has to be problem as it doesn't change and will continue to check the same thing. It's unclear what you want to happen, but consider something like this as it moves to the right until you've exceeded the usedrange.
Sub Chaine()
Dim cell As Range
For Each cell In Range("A2:A3558").Cells
If UCase(cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While cell.Offset(0, 23) <> "T"
Set cell = cell.Offset(0, 1)
'not sure what this is supposed to do...?
'cell.Offset(1, 0).Value = "X"
If cell.Column > cell.Worksheet.UsedRange.Cells(1, cell.Worksheet.UsedRange.Columns.Count).Column Then
MsgBox "This has gone too far left..."
Stop
End If
Loop
End If
Next cell
End Sub

I just went off your description in the question. Your code is not doing what you want and it's not really how you would do this in my opinion. I figured I would put an answer that does what you ask but, keep it simple.
I'm guessing Target in the code refers to an event.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo SomethingBadHappened
'Checks if you are in the A column from the target cell that
'was changed and checks if only X was typed.
If (Target.Column = 1 And UCase(Target) = "X") Then
Dim colToCheck_Index As Integer
colToCheck_Index = 23 'W Column
Dim colToCheck_Value As String
Dim curRow_Index As Integer
curRow_Index = Target.Cells.Row
'Checks if the column we are checking has only a T as the value.
If (UCase(ActiveSheet.Cells(curRow_Index, colToCheck_Index).Value) = "T") Then
Application.EnableEvents = False
Do
'Set the proper cell to X
Range("A" & curRow_Index).Value = "X"
curRow_Index = curRow_Index + 1
'Set the checking value to the next row and check it in the
'while loop if it doesn't equal only T
colToCheck_Value = ActiveSheet.Cells(curRow_Index, colToCheck_Index)
'Set the last row to X on the A column.
Loop While UCase(colToCheck_Value) <> "T"
Range("A" & curRow_Index).Value = "X"
Application.EnableEvents = True
End If
Exit Sub
SomethingBadHappened:
Application.EnableEvents = True
End If
End Sub

Related

Find range between two words and iterate through it with loop

I have created a method for defining range between two words and iterate through it to copy paste values from one worksheet to another. There is some strange reason it does not work.
I specify row, it is 18, my code starts from row 20? So it copies everything starting from row 20. O_o
It does not detect range correctly as it copies values below my words as well? I have checked that I don't have same words elsewhere.
Any suggestions?
Here is code for calling method:
Sub dsfdsfdsfds()
copyOptionsToTable 18, CalculationItemOM1
End Sub
Here is method:
Private Sub copyOptionsToTable(RowToPaste As Integer, OperatingWorksheet As Worksheet)
'Dim FirstWord, SecondWord
Dim OptionsRange As Range
Dim cell, x
'Set FirstWord = OperatingWorksheet.Range("W:W").Find("OPTIOONS START", LookIn:=xlValues, lookat:=xlWhole)
'Set SecondWord = OperatingWorksheet.Range("W:W").Find("OPTIOONS END", LookIn:=xlValues, lookat:=xlWhole)
Set OptionsRange = OperatingWorksheet.Range(OperatingWorksheet.Cells.Find("[OPTIOONS START]"), OperatingWorksheet.Cells.Find("[OPTIOONS END]"))
x = 0
' Copy - Paste process
For Each cell In OptionsRange
If Not IsEmpty(cell.Value) Or cell.Value <> "OPT" Then
ThisWorkbook.Worksheets("TableForOL").Range("B" & RowToPaste).Offset(0 + x, 0).Value = cell.Offset(0 + x, -20).Value
ThisWorkbook.Worksheets("TableForOL").Range("B" & RowToPaste).Offset(0 + x, 3).Value = cell.Offset(0 + x, 2).Value
End If
x = x + 1
Next cell
End Sub
Source sheet:
Output sheet:
EDIT:
Output still looks like this?
You're already incrementing cell by one row inside the loop - you don't need to further offset that using x
Set OptionsRange = OperatingWorksheet.Range( _
OperatingWorksheet.Cells.Find("[OPTIOONS START]").Offset(1,0), _
OperatingWorksheet.Cells.Find("[OPTIOONS END]").Offset(-1, 0))
x = 0
' Copy - Paste process
For Each cell In OptionsRange.Cells
If Not IsEmpty(cell.Value) Or cell.Value <> "OPT" Then
With ThisWorkbook.Worksheets("TableForOL").Range("B" & RowToPaste)
.Offset(x, 0).Value = cell.Offset(0, -20).Value
.Offset(x, 3).Value = cell.Offset(0, 2).Value
End With
x = x + 1 '<< only increment if you copied values...
End If
Next cell
Also I'm not sure this line does what you intend?
If Not IsEmpty(cell.Value) Or cell.Value <> "OPT" Then
maybe
If Not IsEmpty(cell.Value) And cell.Value <> "OPT" Then

Compare the previous value of a cell with the current one

Each of the cells in the “O2: O20” range is populated with numerical values. Next to each one of these cells there is a cell that is also populated with numerical values ​​depending on the value that exists in "O2: 020". For example: If "O2" = 10.2 then the cell on its side "P2" = 1000 but then "P2" = 500, then "P2" = 600, then "P2" = 50; in short, "P2" can take any positive Natural value. I would like to calculate the difference between the previous value that "P2" takes and the current value that it can take as long as "O2" remains with the same value. If the value of "O2" changes, then the difference is not important to me: For example: if "O2" = 10.2 and "P2" = 50 and then "O2" = 10 and "P2" = 3000, in this case, no I want to know the difference, because "O2" is not the same for both cells.
I hope I could understand your problem. Please see this solution.
It is using Option Base 1.
Updated program for writing the difference into the Q column.
If the message is not needed please delete or Rem the line of the last MsgBox.
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
'Static declaration to safe the previous values and change status
Static vO As Variant
Static vP As Variant
Static bolOChanged() As Boolean
'Set up the ranges
Dim rngO As Range, rngP As Range, rngQ As Range
Set rngO = ThisWorkbook.ActiveSheet.Range("O2:O20")
Set rngP = ThisWorkbook.ActiveSheet.Range("P2:P20")
Set rngQ = ThisWorkbook.ActiveSheet.Range("Q2:Q20") 'Range for results
'If the change is not in the range then ignore
If Intersect(Union(rngO, rngP), Target) Is Nothing Then Exit Sub
'Prevent unhandelt multiply changes. If multiply changes required than the
'Target range shall be loop through
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
rngO.Value = vO
rngP.Value = vP
Application.EnableEvents = True
MsgBox "You cannot change more the one cell in the range of: " & Union(rngO, rngP).Address
Exit Sub
End If
'At the firs occasion the current status has to be saved
If VarType(vO) < vbArray Then
vO = rngO.Value
vP = rngP.Value
ReDim bolOChanged(1 To UBound(vO))
End If
Dim iIndex As Long 'Adjust the index of the array to the Row of Target cell
iIndex = Target.Row - rngO(1).Row + 1
If Not Intersect(rngO, Target) Is Nothing Then
'Change was in O range, so next P change shall be ignored
bolOChanged(iIndex) = True
Else
'rngP changed
If bolOChanged(iIndex) Then
'There was a previous O range change, ignore
bolOChanged(iIndex) = False 'Delete the recent change flag
vP(iIndex, 1) = Target.Value 'Store the value
Else
rngQ(iIndex).Value = Target.Value - vP(iIndex, 1)
MsgBox "Value change from: " & vP(iIndex, 1) & ", to: " & Target.Value & ". Difference is: " & Target.Value - vP(iIndex, 1)
vP(iIndex, 1) = Target.Value 'Store the value
End If
End If
End Sub
UPDATE: This version is working with multiply entries.
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
'Static declaration to safe the previous values and change status
Static vO As Variant
Static vP As Variant
Static bolOChanged() As Boolean
'Set up the ranges
Dim rngO As Range, rngP As Range, rngQ As Range
Set rngO = ThisWorkbook.ActiveSheet.Range("O2:O20")
Set rngP = ThisWorkbook.ActiveSheet.Range("P2:P20")
Set rngQ = ThisWorkbook.ActiveSheet.Range("Q2:Q20") 'Range for results
'If the change is not in the range then ignore
If Intersect(Union(rngO, rngP), Target) Is Nothing Then Exit Sub
'At the firs occasion the current status has to be saved
If VarType(vO) < vbArray Then
vO = rngO.Value
vP = rngP.Value
ReDim bolOChanged(1 To UBound(vO))
End If
Dim iIndex As Long 'Adjust the index of the array to the Row of Target cell
Dim item As Variant
For Each item In Target
iIndex = item.Row - rngO(1).Row + 1
If Not Intersect(rngO, item) Is Nothing Then
'Change was in O range, so next P change shall be ignored
bolOChanged(iIndex) = True
Else
'rngP changed
If bolOChanged(iIndex) Then
'There was a previous O range change, ignore
bolOChanged(iIndex) = False 'Delete the recent change flag
vP(iIndex, 1) = item.Value 'Store the value
Else
rngQ(iIndex).Value = item.Value - vP(iIndex, 1)
MsgBox "Value changed in cell " & item.Address & " from: " & vP(iIndex, 1) & ", to: " & item.Value & ". Difference is: " & item.Value - vP(iIndex, 1)
vP(iIndex, 1) = item.Value 'Store the value
End If
End If
Next item
End Sub
This solution uses more columns of your worksheet to store previous values to be compared to actual values. In my example, the values in cells O2 and O3 will always be the same.
Sub Populate_OandP()
'Store previous values
Call PreviousValues
'This code just simulates the data population in columns O and P
Dim intRndNumber As Integer
Range("O2").Value = 10.2
Range("O3").Value = 10
intRndNumber = Int((10 - 1 + 1) * Rnd + 1)
For i = 4 To 20
intRndNumber = Int((10 - 1 + 1) * Rnd + 1)
Cells(i, 15).Value = intRndNumber * 10
Next i
For i = 2 To 20
intRndNumber = Int((10 - 1 + 1) * Rnd + 1)
Cells(i, 16).Value = intRndNumber * 10
Next i
'Check differences
Call CheckDifferenceIfOChanges
End Sub
Sub PreviousValues()
For i = 2 To 20
Cells(i, 18).Value = Cells(i, 15).Value
Cells(i, 19).Value = Cells(i, 16).Value
Next i
End Sub
Sub CheckDifferenceIfOChanges()
For i = 2 To 20
If Cells(i, 18).Value = Cells(i, 15).Value Then
Cells(i, 20).Value = Cells(i, 19).Value - Cells(i, 16).Value
Else: Cells(i, 20).Value = "O columns value changed"
End If
Next i
End Sub

Is using do until best for offsetting a value?

What this is supposed to do: When a user enters a value for ttxt on a userform and clicks on the button 'add' it will first check if the value is blank, and if it is it will enter the input value of the user-- if its not empty, it will go 2 columns over to the right and enter the value there. This will keep adding the value to the right once every button click. I'm not sure how to go about this.
'Starts on column G1
Range("G1").End(xlUp).Offset(2, 0).Select
Do Until ActiveCell.Value = ttxt.Value
If ActiveCell.Value = "" Then
ActiveCell.Value = Me.ttxt
Else
'Offsets to the right 2 columns to enter another value if previous value is
'not empty.
ActiveCell.Offset(0, 2).Value = Me.ttxt
End If
Loop
Me.ttxt = ""
See below
Private Sub addbtn_Click()
Worksheets("Sheet1").Activate
Dim r As Range
Set t = Range("F1").End(xlUp).Offset(2, 0)
Set r = Range("G1").End(xlUp).Offset(2, 0)
Do Until r.Value = "" And t.Value = ""
Set r = r.Offset(, 2) 'Moves over 2 columns
Set t = t.Offset(, 2) 'Moves over 2 columns
Loop
'Inputs values
r.Value = Me.ttxt
t.Value = Me.atxt & ", " & Me.xtxt
With Me.ListBox1
.AddItem
.List(i, 0) = Me.ttxt
.List(0, i) = Me.atxt & ", " & Me.xtxt
i = i + 1
End With
'Clears out userform
Me.ttxt = ""
Me.atxt = ""
Me.xtxt = ""
End Sub
So this is the entire code for the add click button. So this code as you know adds the user input values into the columns like its supposed to. I have a listbox on the userform as well. Whenever a person adds the values to the sheet I want the values to be placed into the listbox as well. The current code adds the first value, and any value after that it just replaces the first value in the listbox. Hopefully you understand what I'm trying to say.
I want the values to keep being added down the list whenever I add them as it does on the sheet.
Sub AlternateColumnsEmpty()
'Starts on column G1
Dim r As Range
Set r = Range("G3")
If r.Value = "" Then
r.Value = Me.ttxt
Else
Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 2).Value = Me.ttxt
End If
Me.ttxt = ""
End Sub
Sub AlternateColumnsHaveData()
'Starts on column G1
Dim r As Range
Set r = Range("G3")
Do Until r.Value = ""
Set r = r.Offset(, 2)
Loop
r.Value = Me.ttxt
Me.ttxt = ""
End Sub

Selecting only the first cell in a range that meets the condition

My code copies a text from a cell in Matrix 1 to all the cells that meet my criteria in Matrix 2. But I want it to copy it only to the first cell that meets my critiria in Matrix 2 and then stop.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
For j = 2 To 2
For i = 21 To 21
If Cells(i, j).Value > 0 Then
Cells(i, j).Value = Cells(i, j).Value - 1
Cells(i, j).Offset(0, -1).Select
End If
'as it says - for EACH - so it copies in aLL the cells'
'I can't Change the range though, cause there will come a Loop eventually'
For Each cell In Range("a1:aap15")
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
End If
End If
Next
Next
Next
End Sub
You can use the Exit For command to exit a for loop. It looks like you want to add it here:
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
Exit For
End If
End If
Note: not tested. Let me know if you have any problems

Changing color in one column based on the value in another

I am new to vba and I am attempting to create a module that takes the value in column C ( which should say "In Progress")and makes it "neutral" colored if the value within the same row on column E is less than 0.5(or 50%) but I have not had any luck. I have a counter variable made to keep track of the row I'm on. Any advice would be helpful and if you could recommend me to a good source for learning vba I would really appreciate it.
If Range("C1") = "Status" Then
Range("C1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Offset(1, 0).Value = "In Progress" Then
If Range("E" & counter).Value < 0.5 Then
ActiveCell.Offset(1, 0).Style = "Neutral"
End If
End If
ActiveCell.Offset(1, 0).Select
Columns("C").ColumnWidth = 13
counter = counter + 1
Loop
End If
End Sub
Untested:
Dim c As Range, sht As WorkSheet
Set sht = ActiveSheet
If sht.Range("C1").Value = "Status" Then
Set c = sht.Range("C2")
Do Until Len(c.Value) = 0
If c.Value = "In Progress" Then
If c.EntireRow.Cells(1, "E").Value < 0.5 Then
c.Style = "Neutral"
Else
c.Style = "Normal"
End If
End If
Set c = c.Offset(1, 0)
Loop
sht.Columns("C").ColumnWidth = 13
End If
As far as I understood your problem and this fits for you, you could try this. The following code searches for value "In Progress" in the entire column A, and if this value is found and the same row cell in column C is less than 0.5, then sets the color of the cell in column A to "no fill".
Sub searchValue()
Dim cell As Range
For Each cell In Worksheets(1).Columns(1).Cells
If cell = "In Progress" Then
If cell.Offset(0, 2) < 0.5 Then cell.Interior.ColorIndex = 0
End If
Next cell
End Sub

Resources