I've what seems like a pretty simple application with looping and 'If..Then' statements but need some help on structuring it.
In very a basic example, I have a list numbers in column A and the values PM or AM listed in column B. I want to write a loop that will search every value in column B until the end of the data set, and add 12 to each value in column A each time column B has a value of PM. In a nutshell, it would look like this:
If column B = PM
then add 12 to its corresponding cell in column A
else move down to the next row and do the same thing until you reach an empty cell
There are many ways, here is a typical one:
Sub dural()
Dim i As Long
i = 1
Do While Cells(i, "B").Value <> ""
If Cells(i, "B").Value = "PM" Then
Cells(i, "A").Value = Cells(i, "A").Value + 12
End If
i = i + 1
Loop
End Sub
you can set it with For next loop and 2 variables. one for last row and the 2nd for the row count:
Sub Macro1()
Dim LastRow As String
Dim i As Integer
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 2).Value = "PM" Then Cells(i, 1).vlaue = Cells(i, 1).vlaue + 10
Next i
End
'
End Sub
This is another way to do this.
Option Explicit
Sub Add()
Dim rData As Range
Dim r As Range
Set rData = Cells(1, 1).CurrentRegion.Columns("B").Cells
For Each r In rData
If UCase$(r.Value) = "PM" Then
r.Offset(, -1).Value = r.Offset(, -1).Value + 12
End If
Next r
End Sub
Related
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'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
Following on from my previous question, I would now like to copy paste values within a cell range.
The code used in my previous query was;
Sub CopyYesInW()
Dim lastRow As Long, i As Long
'determine last row in column W
lastRow = Cells(Rows.Count, "W").End(xlUp).Row
For i = 1 To lastRow
'if Yes in W then copy from P to W in current row
If Cells(i, "W").Value = "Yes" Then
Cells(i, "P").Value = Cells(i, "P").Value
End If
If Cells(i, "W").Value = "Yes" Then
Cells(i, "U").Value = Cells(i, "U").Value
End If
Next
End Sub
I have amended the code in the script below to check the the cell range C6:N6 for values = Yes then copy paste values over the cells in C9:N9. However I am not sure what I am doing wrong. There is a runtime error '5' invalid procedure call or argument
Sub CopyYesInForecast()
Dim lastRow As Long, i As Long
'determine last row in column W
lastRow = Cells("C6")
For i = 1 To lastRow
'if Yes in W then copy from P to W in current row
If Cells(i, "C6:N6").Value = "Yes" Then
Cells(i, "C9:N9").Value = Cells(i, "C9:N9").Value
End If
Next
End Sub
While your narrative is thin, perhaps this is close to what you are attempting.
Sub CopyYesInForecast()
Dim c As Long
For c = range("C:C").column to range("N:N").column
If Cells(6, c).Value = "Yes" Then
Cells(9, c) = Cells(6, c).Value
End If
Next
End Sub
This looks through row 6, column C to N and if it finds Yes then it transfers the value to the same column in row 9.
I hope you can help me my VBA question. I would like to use a loop going down column A. Once a change is detected, I would like to insert a SUMIF formula in column C to total of column B if grouped the column A (Total offset to the right). A is already sorted. Kind of like Subtotal but without using the Subtotaling row.
A B C
1 2
1 6
1 3 11 =SUMIF(A:A,A3,B:B)
2 7
2 8 15 =SUMIF(A:A,A5,B:B)
3 8
3 6 14 =SUMIF(A:A,A7,B:B)
(without the added blank rows between 1 & 2 and 2 & 3 changes) I believe I am part of the way there with the following pieces of code pieces, but am having trouble getting to work together.
Sub SUMIF_Upon_Change()
Dim r As Long, mcol As String, i As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
' insert rows by looping from bottom
For i = r To 2 Step -1
If Cells(i, 1).Value <> mcol Then
Cells(n, 3).Formula = _
"=SUMIF(A:A,RC[-1],B:B)"
'AND / OR This added at the change row minus one row.
'Places formula in each adjacent cell (in column "D").
Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=SUMIF(A:A,A3,BB)"
End If
Next i
End Sub
Any help will be much appreciated.
XLMatters, You pretty much have it. Your only major issue is that you seem to be mixing formula reference styles ("RC[-1]" and "A3"). You have to pick one or the other. Here is a working example of your code with a few minor modifications:
Sub SUMIF_Upon_Change()
Dim r As Long, mcol As String, i As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
For i = r To 2 Step -1
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Cells(i, 3).Formula = "=SUMIF(A:A,A" & i & ",B:B)"
End If
Next i
End Sub
If your heart is set on FormulaR1C1 style, here you go:
Sub SUMIF_Upon_ChangeRC()
Dim r As Long, mcol As String, i As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
For i = r To 2 Step -1
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Cells(i, 3).FormulaR1C1 = "=SUMIF(C1,RC1,C2)"
End If
Next i
End Sub
Should you have any other questions, just ask.
I've got 2 sheets in my workbook in Excel 2010. The first got a row with names, listed like this:
Jens A.
Christian
Peter
Jens A.
Anders
Jens A. etc.
On the second sheet I want to make a combobox, which show all the names from the first sheet, but without duplicates. Is that possible to make in VBA code?
In addition I want to make the list dynamic, but I guess I've just have to call the function in:
Private Sub Workbook_Open()
To make that happen?
Thanx in advance
Plese check the below macro. It operates on 2 columns but you can adjust it.
Option Explicit
Sub UniqueRecords()
Dim i As Long
Dim j As Long
Dim k As Long
Dim bDuplicate As Boolean
i = 1
Do Until Cells(i, 1).Value = ""
'check if record exist
j = 1
Do Until Cells(j, 2).Value = ""
bDuplicate = False
If Cells(i, 1).Value = Cells(j, 2).Value Then
bDuplicate = True
Exit Do
End If
j = j + 1
Loop
'add record if no duplicate
If bDuplicate = False Then
For k = 1 To ActiveSheet.Rows.Count
If Cells(k, 2).Value = "" Then
Cells(k, 2).Value = Cells(i, 1).Value
Exit For
End If
Next k
End If
i = i + 1
Loop
End Sub