Hi does anyone know how to use excel vba to highlight if the same combination of data appears in another row, within the same group of items (an empty row is used to split them)?
You can use conditional formatting with a "helper column"
Formula for helper column:
column can be anyplace on the worksheet, and can be hidden
D2: =A2&B2&C2 *and fill down as far as needed*
Then select the three column/ranges to be formatted.
Conditional formatting using a formula:
=AND(COUNTIF($D$2:$D$15,$D2)>1,$D2<>"")
and set the format for your interior fill
Edit
If the Items within each group are not all the same, as you are now showing in your revised example, then we merely add another helper column: Index with the formula:
E2: =IF(A2="",ROW(),$E1)
And we change the concatenation formula in Column D to:
D2: =TEXT($E2,"000")&B2&C2
Try to this code it my help!
Sub InsBl()
Dim rng, cel As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A2:A" & LR)
For Each cel In rng
If WorksheetFunction.CountIf(rng, cel.Value) > 1 Then
cel.Interior.ColorIndex = 6
Else
cel.Interior.ColorIndex = xlNone
End If
Next cel
End Sub
Dim rng, rng1, cel, cel1 As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("B2:B" & LR)
Set rng1 = Range("C2:C" & LR)
For Each cel In rng
If WorksheetFunction.CountIf(rng, cel.Value) > 1 Then
For Each cel1 In rng1
If WorksheetFunction.CountIf(rng1, cel.Offset(0, 1).Value) > 1 Then
cel.Offset(0, 1).Interior.ColorIndex = 6
cel.Interior.ColorIndex = 6
End If
Next cel1
Else
cel.Interior.ColorIndex = xlNone
End If
Next cel
Related
So I have some "working code". Specifically, I am looking at a Range in Excel, then if I see "Yes" in a cell, coloring it Yellow and doing it for all the other cells in the range. Works GREAT.
Now I would like to sort of tweak the Fixed Range and have Excel look at the each column header and only perform this coloring based on the suffixes that I say. In this case, I would only like it to do this evaluation on the columns ending in "_ty".
Here is the code I have to color the entire range of cells:
Sub ColorCellRange()
Dim c As Range
' Loop through all cells in range A1:E + last used Row in column A
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
'Look for Yes
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
'Color the cell RED
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next
End Sub
Current output of code
Another approach: scan the column headers and decide if to process the cells below.
Sub ColorCellRange()
Dim c As Range, hdr As Range, ws As Worksheet
Set ws = ActiveSheet 'or whatever
'loop over all headers in Row 1
For Each hdr In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
If hdr.Value Like "*_ty" Then 'is this a header we're interested in ?
For Each c In ws.Range(hdr.Offset(1), ws.Cells(Rows.Count, hdr.Column).End(xlUp)).Cells
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
c.Interior.Color = vbYellow
End If
Next c
End If ' like "_ty"
Next hdr
End Sub
try this:
Option Compare Text
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If c.Value Like "*Yes*" And Cells(1, c.Column).Value Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
or you can remove Option Compare Text and convert .value to low/upper case:
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If LCase(c.Value) Like "*yes*" And _
LCase(Cells(1, c.Column).Value) Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
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
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 entered the Cells in Column A, B, C, D, AND I Want the result as entered in F, G, H, I, so what formula i should insert i the cells
F3 would be:
=IF(ISERROR(MATCH(ROW()-2,A:A,0)),"",ROW()-2)
And G3:
=IF(LEN(F3),INDEX(B:B,MATCH(F3,A:A,0)),"")
copy F3:G3 to H3:I3 and "auto fill" down as you need to
If you want to use a macro instead, then just copy this code into a module in visual basic editor and run it.
Sub insertRows()
Columns("G:J").EntireColumn.Delete
Dim lrow As Long: lrow = Range("A" & Rows.Count).End(xlUp).Row
Dim brng As Range: Set brng = Range("A1:D" & lrow)
brng.Copy Range("G1"): Range("G1").Value = "After"
Dim arng As Range: Set arng = Range("G3:G" & lrow)
Dim rng As Range
For Each rng In arng
If rng <> rng.Offset(, 2) Then
If rng > rng.Offset(, 2) Then
rng.Resize(, 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Else
rng.Offset(, 2).Resize(, 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End If
Next rng
End Sub
OMG, this one is difficult but these are the formulas you can try:
From cell F3:
=IF(AND(N(F2)=0,F2<>""),1,IF(AND(NOT(COUNTIF($A$3:$A$22,MIN(INDEX($A$3:$A$22,MATCH(MAX(F$2:F2,H$2:H2),$A$3:$A$22,1)+1),INDEX($C$3:$C$22,MATCH(MAX(F$2:F2,H$2:H2),$C$3:$C$22,1)+1)))),INDEX($A$3:$A$22,MATCH(MAX(F$2:F2,H$2:H2),$A$3:$A$22,1)+1)),"",INDEX($A$3:$A$22,MATCH(MAX(F$2:F2,H$2:H2),$A$3:$A$22,1)+1)))
From cell G3:
=IF(N(F3),INDEX(B:B,MATCH(F3,A:A,0)),"")
From cell H3:
=IF(AND(N(H2)=0,H2<>""),1,IF(AND(NOT(COUNTIF($C$3:$C$22,MIN(INDEX($C$3:$C$22,MATCH(MAX(H$2:H2,F$2:F2),$C$3:$C$22,1)+1),INDEX($A$3:$A$22,MATCH(MAX(H$2:H2,F$2:F2),$A$3:$A$22,1)+1)))),INDEX($C$3:$C$22,MATCH(MAX(H$2:H2,F$2:F2),$C$3:$C$22,1)+1)),"",INDEX($C$3:$C$22,MATCH(MAX(H$2:H2,F$2:F2),$C$3:$C$22,1)+1)))
From cell I3:
=IF(N(H3),INDEX(D:D,MATCH(H3,C:C,0)),"")
Basically, the formulas are very similar under both Debit and Credit columns but just swapping the range references. Try and let me know.
I am tying to manage duplicates on an Excel sheet by having the duplicate cells turn red. I put this in a use to sheet protection to keep from editing the conditional formatting for these columns. However, when I move the cell information (by clicking and dragging) the conditional formatting moves from that cell as well. At the end of the day, I do not have duplicate coverage for every cell that I want. Is there some way I can prevent this from happening when I move the cell, or what macro can I put in to take care of this?
I want to do something like this using VBA:
Sub Duplicate()
Dim rngData As Range
Dim cell As Range
Set rngData = Range("P3:P19, P56:P58, P39:P42, P21:P25, P27:P37, P39:P42, P39:P42, P44:P54, M25:M76, B69:B77, B66:E67, B51:B64, H44:H47, D44:D47, H42, H33:H40, D33:D42, H31, D28:D31, H28:H29, D5:D8" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each cell In rngData
cell.Offset(0, 0).Font.Color = vbBlack ' DEFAULT COLOR
' LOCATE DUPLICATE VALUE(S) IN THE SPECIFIED RANGE OF DATA.
If Application.Evaluate("COUNTIF(" & rngData.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed ' CHANGE FONT COLOR TO RED.
End If
Next cell
Set rngData = Nothing
Application.ScreenUpdating = True
End Sub
But I get a "Type Mismatch" error at:
If Application.Evaluate("COUNTIF(" & rngData.Address & "," & cell.Address & ")") > 1 Then
How can I get around this?
As per comment you would need to loop twice:
Sub Duplicate()
Dim rngData As Range
Dim cell As Range
Dim cell2 As Range
Set rngData = Range("P3:P19, P56:P58, P39:P42, P21:P25, P27:P37, P39:P42, P39:P42, P44:P54, M25:M76, B69:B77, B66:E67, B51:B64, H44:H47, D44:D47, H42, H33:H40, D33:D42, H31, D28:D31, H28:H29, D5:D8" & Cells(Rows.Count, "B").End(xlUp).Row)
rngData.Font.Color = vbBlack
For Each cell In rngData
If cell.Font.Color = vbBlack Then
For Each cell2 In rngData
If cell = cell2 And cell.Address <> cell2.Address Then
cell.Font.Color = vbRed
cell2.Font.Color = vbRed
End If
Next
End If
Next
Set rngData = Nothing
Application.ScreenUpdating = True
End Sub