I am trying to write a VBA to compare AB and AE Column and check if the AB column contains the value as "High" then the corresponding AE column should not contain the date which is less than current date - 10 months otherwise the cell should be highlighted in red. I tried the below code but it is highlighting all the date values.
Dim High As Range
Dim StartDate As Date
For Each High In Range("AB:AB")
If High.Value = "High" Then
If Not IsDate(Range("AE" & High.Row) = StartDate - 300) Then
Range("AE" & High.Row).Interior.Color = 255
End If
End If
Next High
Like Pᴇʜ has already mentioned, you could accomplish this by using conditional formatting. However, if you want to colour the cells once, statically, edit your code to the following:
Dim High As Range
Dim StartDate As Date
StartDate = Date
With Workbooks(REF).Sheets(REF) 'Add correct references
LRow = .Cells(.Rows.Count, "AB").End(xlUp).Row
For Each High In .Range("AB2:AB" & LRow) 'Assuming you have a header row
If High.Value = "High" Then
If IsDate(.Range("AE" & High.Row)) = False Then
.Range("AE" & High.Row).Interior.Color = vbRed
Else
If DateValue(.Range("AE" & High.Row)) < StartDate -300 Then .Range("AE" & High.Row).Interior.Color = vbRed
End If
End If
Next High
End With
The code uses the OPs "Not IsDate(), removes the extra IFs using And/Or, using Offset assigns the second cell as a variable, and colors both cells at the same time using the cell variables and .address.
Dim sDate As Date, cel As Range, cel2 As Range
sDate = Date
With ThisWorkbook.Sheets("Sheet1")
'loop through each cell in range, does not use lRow variable
For Each cel In .Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set cel2 = cel.Offset(, 4) 'Set the second cell variable to column E using offset
'Use And/Or in the IF statement to test the values in the ranges
If cel.Value = "High" And (Not IsDate(cel2) Or cel2 < sDate - 300) Then
'Set both cells color at the same time using the cell address for both variables
Range(cel.Address & "," & cel2.Address).Interior.Color = vbRed
End If
Next cel
End With
Related
On an excel sheet, if there is a list of numbers and next to it a letter to determine what category it's in, how would I be able to change blank or 0 values with a formula depending on the category?
In this case there's a list of price and weight for product a,b,and c. the average price for the products are already known and is in a table on the same excel sheet. To fill in the 0 data with an estimate of how much the product would've weighed, what would the code look like.
Sub test()
Dim RNG As Range
For Each RNG In Range("A2:A")
If RNG.Value = "0" And RNG.Offset(0, 2) = "a" Then RNG.Offset(0, 0).Formula = "=RC[1]/Cells(2,5)"
If RNG.Value = "0" And RNG.Offset(0, 2) = "b" Then RNG.Offset(0, 0).Formula = "=RC[1]/Cells(3,5)"
If RNG.Value = "0" And RNG.Offset(0, 2) = "c" Then RNG.Offset(0, 0).Formula = "=RC[1]/Cells(4,5)"
Next RNG
End Sub
The real data is thousands of lines so manually doing it is not prefered. There are a few things like the RNG.Offest(0,0) that I'm not particularly happy about but it doesn't return a syntax error so i've stuck with it.
Can anyone help me out?
If I'm not mistaken to understand what you want ...
The code below assumed that all the data rows in column D are unique.
Sub test1()
Dim rg As Range
Dim cell As Range
With ActiveSheet
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each cell In rg
If cell.Value = 0 Then _
cell.Value = cell.Offset(0, 1).Value / .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Find(cell.Offset(0, 2).Value, lookat:=xlWhole).Offset(0, 1).Value
Next
End With
End Sub
Sub test2()
Dim rg As Range
Dim cell As Range
Dim c As String
With ActiveSheet
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each cell In rg
If cell.Value = 0 Then
c = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Find(cell.Offset(0, 2).Value, lookat:=xlWhole).Offset(0, 1).Address
cell.Value = "=" & cell.Offset(0, 1).Address & "/" & c & ""
End If
Next
End With
End Sub
Sub test1 will put a value to the cell which value = 0
Sub test2 will put a formula to the cell which value = 0
(based on your image attachment) :
cell A4 show a result from a calculation of : cell B4 value / cell E2 value = 1.0333
cell A7 show a result from a calculation of : cell B7 value / cell E3 value = 3.3293
This is what my end result should look like. If there is not the four digits to move over to the second column then fill with 4 zeros.
How can I split zip code in a column into 2 columns and fill empty cells in column 2 if first column has only 5 digits?
Here is what I have been working with
Dim ws As Worksheet
Dim cell As Range
Set ws = Worksheets("sheet1")
For Each cell In ws.Range("K2:K500").Cells
cell.Offset(0, 1).Value = Left(cell.Value, 5)
Next cell
Dim cel As Range, rngC As Range, rngB As Range
Dim lastRowA As Long, lastRowB As Long
With ws
lastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row 'last row of column A
lastRowL = .Cells(.Rows.Count, "L").End(xlUp).Row 'last row of column B
For Each cel In .Range("K2:K" & lastRowL) 'loop through column L
'check if cell in column A exists in column B
If WorksheetFunction.CountIf(.Range("K2:K" & lastRowL), cel) = 0 Then
cel.Offset(0, 3).Value = Right(cel.Value, 4)
'.Range("M" & cel.Row) = Right(cell.Value, 4)
Else
.Range("M" & cel.Row) = "0000"
End If
Next
End With
In case you want to bypass VBA and use formulas, you can do this.
Cell B2:
=LEFT(A2,5)
Cell C2:
=IF(LEN(A2)=9,RIGHT(A2,4),"0000")
One of the simplest ways to solve this problem is to supplement the original string with a large number of zeros and take the values of the first and second five characters for two cells:
Sub setZIPandZeros()
Const TEN_ZEROS = "0000000000" ' 10 times
Dim ws As Worksheet
Dim cell As Range
Dim sLongString As String
Set ws = Worksheets("Sheet1")
For Each cell In ws.Range("K2:K" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).Cells
sLongString = Trim(cell.Text) & TEN_ZEROS
cell.Offset(0, 1).Resize(1, 2).NumberFormat = "#"
cell.Offset(0, 1).Resize(1, 2).Value = Array(Left(sLongString, 5), _
Mid(sLongString, 6, 5))
Next cell
End Sub
Update The modified code is much faster and gives a result that more closely matches the description of the task:
Sub setZipZeros()
Dim ws As Worksheet
Dim rResult As Range
Set ws = Worksheets("Sheet1")
' Addressing R1C1 is used in the formulas - If the original range
' is shifted to another column, you will need to change the letter
' of the column "K" only in this line
Set rResult = ws.Range("K2", ws.Cells(ws.Rows.Count, "K").End(xlUp)).Offset(0, 1)
' If the columns L:M are already in text format, then instead of
' the results we will get the texts of formulas
rResult.Resize(, 2).NumberFormat = "General"
' These two lines do most of the work:
rResult.Formula2R1C1 = "=LEFT(TRIM(RC[-1])&""00000"",5)"
rResult.Offset(0, 1).Formula2R1C1 = "=MID(TRIM(RC[-2])&""000000000"",6,4)"
' We don't know if auto-recalculation mode is on now
' Application.Calculation = xlAutomatic
ActiveSheet.Calculate
Set rResult = rResult.Resize(, 2)
' Set the text format for the cells of the result
' to prevent conversions "00123" to "123"
rResult.NumberFormat = "#"
' Replace formulas with their values
rResult.Value = rResult.Value
End Sub
I'm trying to sort a range of rows in an Excel sheet which all start with a specific green background colour in the first column, but my vba code does not do it at all and I can't see why. The objective is as an example to get from this:
to this:
Private Sub Sort_Click()
Dim StartRow, EndRow, i As Integer
Dim row As Range, cell As Range
'Discover the data starting and end rows
i = 1
StartRow = 1
EndRow = 1
'Check the first cell of each row for the start of background colour
For Each row In ActiveSheet.UsedRange.Rows
Set cell = Cells(row.row, 1)
If i < 3 Then
If Hex(cell.Interior.Color) = "47AD70" And i = 1 Then
StartRow = row.row
i = 2
ElseIf Hex(cell.Interior.Color) <> "47AD70" And i = 2 Then
EndRow = row.row - 1
i = 3
End If
End If
Next row
'Sort the range
Range("A" & StartRow & ":" & "A" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
End Sub
The code should check the first cell of each row in Column "A" until it reaches the first green backgroend colour where it assigns that row number to the variable StartRow. The loop continues until it no longer detects the green background colour in the first cell. It then assigns that row number - 1 to the variable EndRow. At the end, it sorts the green range numerically using StartRow and EndRow as the range.
Possibly, The Range statement part is not working correctly. I wonder if someone could help with a resolution or a better code all together. The images demonstrate the rows in the green range sorted manually. Thanks in advance
You need to use last parameter of Find method SearchFormat. Set it to whatever format you need:
Sub FGG()
Dim rng As Range, rngStart As Range, rngEnd As Range
'// Clear previous format, if any
Application.FindFormat.Clear
'// Set search format
Application.FindFormat.Interior.Color = Hex("47AD70")
'// Find first cell with format
Set rngStart = Range("A:A").Find(What:="*", SearchFormat:=True)
'// Find last cell with format by using xlPrevious
Set rngEnd = Range("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchFormat:=True)
'// Define final range
Set rng = Range(rngStart, rngEnd)
'// Sort range and say that that the range has no header
rng.Sort Key1:=rng(1), Header:=xlNo
End Sub
Well, I may have been a bit silly on this issue here, however after some more reading it turned out that to sort complete rows rather than column A only, all I simply had to do was to actually specify whole rows rather than a single column, in the sorting part of the code!
And that is dpne by replacing the line:
Range("A" & StartRow & ":" & "A" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
with:
Range("A" & StartRow & ":" & "D" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
All that's happened above is that the "A" in the range section has changed to "D" to cover all used columns for sorting the rows.
I have an Excel workbook with worksheets formatted as follows:
I have been trying to write some code that will populate the "% Weight" column with a formula that will divide the value of the adjacent cell in "Weight" column by the value of the cell that contains the sum function below each range of cells.
I have dozens of tables on a sheet, divided by a few blank rows, all formatted like this vertically. I need the cells to identify the correct sum cell and divide the offset cell by the value.
I have tried the below code.
Basically I tried to run a For Each loop through the "% Weight" column and identify when the adjacent cell in "Weight" was not empty. Then it would identify the offset cell by setting a range variable, and then set another variable to identify the final cell in the range therefore identifying the cell containing the sum formula.
I do know that my If logic is working though, as I had to populated "% Weight" column with a value of "1" if there was an adjacent cell and that worked.
I keep getting error 424 or type mismatch.
Code block providing issues:
Dim cell As Range, rng2 As Range, sideweight As Range, TargetWeight As Range
Dim TargetWeightr As Long, Dim TargetWeightc As Long
rng2 = Range("D1:D" & LR)
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sidewight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
Set TargetWeightr = TargetWeight.Address.Row
Set TargetWeightc = TargetWeight.Address.Column
'cell.FormulaR1C1 = "=RC[-1]/R[" & TargetWeightr & "]C[" & TargetWeightc & "]"
End If
Next cell
Entire Macro For Context:
Sub WeightCalculations2()
Application.ScreenUpdating = False
Dim rng As Range, cell As Range, rng2 As Range, rA As Range, totalweight As Range, totalweightrng As Range
Dim sideweight As Range, TargetWeight As Range
Dim LR As Long, TargetWeightr As Long, TargetWeightC As Long
Dim ws As Worksheet
Set ws = ActiveSheet
With ActiveSheet
LR = Cells(Rows.Count, "A").End(xlUp).Row
End With
Set rng = ws.Range("I2:I" & LR)
Set rng2 = ws.Range("J2:J" & LR)
For Each cell In rng
If cell.Offset(0, -1).Value = "EA" Then cell.FormulaR1C1 = "=RC[-2]*RC[3]"
If cell.Offset(0, -1).Value = "LB" Then cell.FormulaR1C1 = "=RC[-2]*1"
Next cell
For Each cell In rng
If WorksheetFunction.IsError(cell) Then cell.Formula = "=1*0"
Next cell
For Each rA In Columns("I").SpecialCells(xlFormulas).Areas
rA.Cells(rA.Cells.Count + 1).Formula = "=SUM(" & rA.Address & ")"
Next rA
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sidewight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
Set TargetWeightr = TargetWeight.Address.Row
Set TargetWeightC = TargetWeight.Address.Column
'cell.FormulaR1C1 = "=RC[-1]/R[" & totalweightrn & "]C[" & totalweightcn & "]"
End If
Next cell
End Sub
Expected Output:
The program populates the cells in the column "% Weight" with the formula dividing the value of the corresponding offset cell in the "Weights" column by the value of the cell containing the sum for the corresponding range of cells.
Actual Output:
Error 424 and/or Error Mismatch.
TargetWeight.Address.Row should be TargetWeight.Row
TargetWeight.Address.Column should be TargetWeight.Column
When you create an xlR1C1 style address, the n inside [n] is a relative row or column adjustment. RC[-1] means same row, one column left. You want an absolute address and you have absolute row and column as long integers so R" & totalweightr & "C" & totalweightc
You don't Set integer values, you assign them with an =. You only Set objects like ranges, cells, worksheets, etc.
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sidewight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
TargetWeightr = TargetWeight.Row
TargetWeightc = TargetWeight.Column
cell.FormulaR1C1 = "=RC[-1]/R" & TargetWeightr & "C" & TargetWeightc
End If
Next cell
You might also want to forget all of the manipulation and just use TargetWeight.Address in xlR1C1 style.
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sideweight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
cell.FormulaR1C1 = "=RC[-1]/" & TargetWeight.Address(referencestyle:=xlR1C1)
End If
Next cell
I need help to write a code which puts an R1C1 formula into a row’s cells.
The start position of the row’s will vary each time the macro is run.
Ie. If the macro is run the first time, the formula will be entered into Row B16 as R[-5]C[3]. R[-5] in the case is E12.
However, when the macro is run another time, & its entered into row B25, I still want it to reference to E3, but it references to E20.
Here is my code
Dim cell As Range, MyRange As Range
Set MyRange = Range("B1:B5000")
For Each cell In MyRange
If cell = " " And cell.Offset(, 1) <> "Record" Then
cell.FormulaR1C1 = "=SUM(R[-5]C[3]: SUM(R[-5]C[4])"
End If
Next cell
End With
You are right, my code was trying to say This row - 5, this column + 3: this row -5, this column + 4
The problem I have is that This row could be any row & I would like to use relative referencing as this formula copies down to the next row
So what I’m trying to do is this
Cell B16 = E11+F11
Cell B17 = E12+F12
Cell B18 = E13+F13 etc
Then when the macro is run again & start cell is E25, then
Cell E25 = E20+F20
Cell E26 = E21+F21
Cell E26= E22+F22 etc
So, regardless of which cell the macro points to, it will always start the calculation from E11+F11
Here is my code
Dim cell As Range, MyRange As Range
Set MyRange = Range("B1:B5000")
For Each cell In MyRange
If cell = " " And cell.Offset(, 1) <> "Record" Then
cell.FormulaR1C1 = "=SUM(R[-5]C[3]: SUM(R[-5]C[4])"
End If
Next cell
End With
You're using relative references in your formula, and the formula won't work as you're trying to say =SUM(E1:SUM(F1) if the entered in cell B6. Any rows higher than that and it will try and reference off the sheet.
To use absolute referencing use R3C5 (row 3, column 5 = E3).
At best your formula was trying to say This row - 5, this column + 3: this row -5, this column + 4
Maybe try "=SUM(R3C5:R3C4)" which is the same as =SUM($E$3:$F$3).
Also - cell = " " - the cell must contain a single space? Should it be cell = ""?
Edit:
In response to your edit - if you want the first formula to always look at E11:F11, and the next to be E12:F12, etc you can use one of these solutions:
To add the formula to all rows in one hit - this doesn't check for a cell with a space:
Public Sub Test()
Dim MyRange As Range
Dim lOffset As Long
Set MyRange = Range("B1:B5000")
With MyRange
lOffset = 11 - .Row
.FormulaR1C1 = "=IF(RC[1]<>""Record"",SUM(R[" & lOffset & "]C5:R[" & lOffset & "]C6),"""")"
End With
End Sub
To check that each cell has a space in it before adding the formula:
Public Sub Test1()
Dim MyRange As Range
Dim rCell As Range
Dim lOffset As Long
Set MyRange = Range("B30:B5000")
lOffset = 11 - MyRange.Row
For Each rCell In MyRange
If rCell = " " And rCell.Offset(, 1) <> "Record" Then
rCell.FormulaR1C1 = "=SUM(R[" & lOffset & "]C5:R[" & lOffset & "]C6)"
End If
Next rCell
End Sub
Here's the results for the second code block showing the formula always starts in row 11:
And if you change the range the formula goes in:
Edit 2:
If rows 20:24 have Record then this will place =SUM($E11:$F11) in row 25. If row 26 has a record then row 27 will have =SUM($E12:$F12)
Public Sub Test1()
Dim MyRange As Range
Dim rCell As Range
Dim lOffset As Long
Set MyRange = Range("B20:B30")
lOffset = 11
For Each rCell In MyRange
If rCell = " " And rCell.Offset(, 1) <> "Record" Then
rCell.FormulaR1C1 = "=SUM(R[" & lOffset - rCell.Row & "]C5:R[" & lOffset - rCell.Row & "]C6)"
lOffset = lOffset + 1
End If
Next rCell
End Sub