I have a table that has a header and the first column has student names. the rest of the table has student scores.
I need to highlight all the cells with zeros in them so far this is what i got
Sub HighLightZeros()
Dim region As Range
Set region = ActiveSheet.Range("a1").End(xlDown)
If region.Value = 0 Then
region.Interior.Color = vbYellow
Else
region.Interior.ColorIndex = xlColorIndexNone
End If
End Sub
Also I have to make the macro so that when I add more scores to end on the table that it still highlights all the zero values. I am having trouble in figuring out how to select the entire table.
you could like follows
Sub HighLightZeros()
With ActiveSheet.UsedRange
With .Resize(, .Columns.Count - 1).Offset(, 1) 'reference all "used" cells except column A ones
.Interior.ColorIndex = xlColorIndexNone ' uncolor referenced range
.Replace what:=0, lookat:=xlWhole, replacement:="XXX" ' replace 0's with "XXX"
.SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues).Interior.Color = vbYellow ' color referenced range cells with text content in yellow
.Replace what:="XXX", lookat:=xlWhole, replacement:=0 ' replace "XXX"'s with 0
End With
End With
End Sub
trying to build up some working code from your skeleton in the question, it could be
Sub HighLightZeros2()
Dim region As Range, cell As Range
Set region = Range("a1", Range("A1").End(xlDown))
For Each cell In region
If cell.Value = 0 Then
cell.Interior.Color = vbYellow
Else
cell.Interior.ColorIndex = xlColorIndexNone
End If
Next
End Sub
but it'd scan the first column cells only
This is less efficient than #DisplayName's method but another way. Assumes table is an actual table (List object. Created with Ctrl + T)
Option Explicit
Sub HighlightZeroes()
Dim table As ListObject
Dim currentCell As Range
Set table = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1") 'change as required
For Each currentCell In table.DataBodyRange
With currentCell
.Interior.ColorIndex = xlColorIndexNone
If .Value = 0 Then .Interior.Color = vbYellow
End With
Next currentCell
End Sub
Related
I am currently trying to write a macro with which I can check if in Column A there is any value multiple times. If there is a value twice I want the macro to copy the value of the cell next to the cell that is double and paste it, in the cell next to the original cell, divided by the contents of the cell it is pasted in with a ";". I know that sentence is quite complex but I find it hard to describe my problem.
This is the worksheet not "damaged" by my macro
The stuff I just described works more or less, the problem I have is that, if there is a cell with the same content multiple times, and the cell next to those also has the same value, the macro, logically, puts in the value multiple times as well. I don't really know how to stop that. Also, with my macro so far if a cell next to the cell that exists twice is empty, the macro can result to putting many, unwanted, ";".
This is after my macro "destroyed" the sheet
I am still quite new to VBA and very greatful for any help that I can get!
Edit:
Here is what I came up with so far
Option Explicit
Sub Dopplungen()
Dim rng As Range, rng2 As Range, rcell As Range, rcell2 As Range, valueold As String, valuenew As String
Set rng = ThisWorkbook.Sheets("Data").Range("A2:A500")
For Each rcell In rng.Cells
If rcell.Value <> vbNullString Then
For Each rcell2 In rng.Cells
If rcell.Value = rcell2.Value Then
If rcell.Address <> rcell2.Address Then
valueold = rcell.Offset(0, 1).Value
valuenew = rcell2.Offset(0, 1).Value
If rcell.Offset(0, 1).Value <> rcell2.Offset(0, 1).Value Then
If rcell2.Offset(0, 1).Value <> "" Then
If rcell.Offset(0, 1).Value <> "" Then
rcell.Offset(0, 1).Value = valueold & ";" & valuenew
Else
rcell.Offset(0, 1).Value = valuenew
End If
End If
End If
End If
End If
Next rcell2
End If
Next rcell
End Sub
one possibility is using Dictionary object, which has the property of having unique keys
like per this code (explanations in comments):
Option Explicit
Sub main()
Dim fruitRng As Range
Dim cell As Range
With Worksheets("fruits") 'change "fruits" to your actual worksheet name
Set fruitRng = .Range("B1", .Cells(.Rows.Count, 1).End(xlUp)) 'get its range in columns "A:B" from row 1 down to column A last not empty cell
End With
With CreateObject("Scripting.Dictionary")
For Each cell In fruitRng.Columns(1).Cells 'first loop to get unique fruit names and associate them a dictionary
Set .Item(cell.Value) = CreateObject("Scripting.Dictionary")
Next
For Each cell In fruitRng.Columns(1).Cells 'second loop to fill each fruit dictionary with its color
If cell.Offset(, 1).Value <> "" Then 'mind only not empty color cells
With .Item(cell.Value) 'reference the current fruit dictionary
.Item(cell.Offset(, 1).Value) = .Item(cell.Offset(, 1).Value) 'add current color in its keys, so you get a unique list of them
End With
End If
Next
For Each cell In fruitRng.Columns(1).Cells 'third loop to finally write down the colors next to each fruit
cell.Offset(, 1).Value = Join(.Item(cell.Value).Keys, ";")
Next
End With
End Sub
I have section title cells set at 10 pt font while all other data is set at 9 point font in column A. I am trying to write a vba macro to loop through column A to move each title cell down one row(because the csv leaves a blank cell below them) then move on to the next title cell in the column. Here is my attempt but I'm not sure what I'm doing wrong here.
Sub FontSpacing()
Dim Fnt As Range
For Each Fnt In Range("A8:A5000")
If Fnt.Font.Size = "10" Then
ActiveCell.Cut Destination:=ActiveCell.Offset(",1")
End If
Next
Try this
Sub FontSpacing()
Dim r As Range
For Each r In ThisWorkbook.Worksheets("Sheet1").Range("A8:A5000")
If r.Font.Size = 10 Then
r.Offset(1,0).Value = r.Value
r.Value = vbNullString
End If
Next r
End Sub
The issues:
Offset(",1") shouldn't have the speech marks. I.e. it should be Offset(0,1). In fact, if you want to paste to the row below, then it should be Offset(1,0).
Avoid using ActiveCell. It's not the cell that is looping through your range, it's just the cell that was active on the worksheet when you ran the sub.
Fnt is a bad name for a range, it's probably the reason you got confused. When declaring (dimensioning) a range, try to give it a name that makes it clear you're working with a range.
Extra:
Fully qualify your range reference to avoid an implicit reference to the ActiveSheet e.g. ThisWorkbook.Worksheets("Sheet1").Range("A1").
Avoid cutting an pasting by setting the Value directly
Your indentation is out, which makes it look like a complete Sub, but it's missing the End Sub.
Not sure if you meant 1 Row below or 1 Column right so:
To shift 1 Column:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
cell.Offset(0, 1).Value = cell.Value
cell.Clear
End If
Next
End Sub
To shift 1 Row:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
a = cell.Row + 1
Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=1
cell.Offset(1, 0).Value = cell.Value
cell.Offset(1, 0).Font.Size = "11"
cell.Clear
End If
Next
End Sub
I need some help in creating a simple VBA to create a parent row for a list of items with variables.
my screenshot
As seen in the screenshot, right now my data is similar to the "before" table. I am trying to create a VBA script which loops through all the rows and creates new row based on the group. I want to create a new row for every group number, and on that new row, it copies certain values from the cell below it.
Thanks!
Nelson
You can insert blank rows like this:
Sub Macro1()
Dim i As Long
i = 3
Do While Cells(i, 1) <> ""
If Cells(i, 1) <> Cells(i - 1, 1) Then
Rows(i).Insert Shift:=xlDown
i = i + 1
End If
i = i + 1
Loop
End Sub
Hopefully changing the cells should not be an issue now
the following code should let you change it easily to your current and, possibly, future needs
I assumed, as per your linked example, that "Description" column always has one non blank cell at the beginning of every "Group" or "SKU" rows block
Sub CreateRowForParentItem()
Dim sht As Worksheet
Dim cell As Range
Dim descriptionCol As Long, SKUCol As Long, productCol As Long
'------------------------------
' setting stuff - begin
descriptionCol = 10 '<== adapt it to your actual "Description" column number
SKUCol = 5 '<== adapt it to your actual "SKU" column number
productCol = 6 '<== adapt it to your actual "Product Title" column number
Set sht = ThisWorkbook.Sheets("SheetFruit") '<== change 'data' sheet as per your needs
' setting stuff - end
'------------------------------
'------------------------------
' core code - begin
With sht
Set cell = .Cells(.Rows.Count, descriptionCol).End(xlUp) '<== find last non blank cell in "Description" column
Do While cell.value <> "Description" '<== proceed only if it's not the header cell
cell.EntireRow.Insert
Call CopyAndClearRange(.Cells(cell.row, SKUCol))
Call CopyAndClearRange(.Cells(cell.row, productCol))
Call CopyAndClearRange(.Cells(cell.row, descriptionCol), True)
Set cell = .Cells(cell.row - 1, descriptionCol).End(xlUp) '<== find next non blank cell up
Loop
End With
' core code - end
'------------------------------
End Sub
Sub CopyAndClearRange(rng As Range, Optional okClear As Variant)
If IsMissing(okClear) Then okClear = False
With rng
.Copy .Offset(-1)
If okClear Then .Clear
End With
End Sub
Try this:
Sub Add_Row()
Range("I3").Select 'This assumes the first row of data after column headers is row 3
While ActiveCell <> ""
If ActiveCell.Offset(0, 1).Value <> "" Then
Selection.EntireRow.Insert
ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(1, 1).Value
ActiveCell.Offset(1, 1).ClearContents
ActiveCell.Offset(0, -3).Value = ActiveCell.Offset(1, -3).Value
ActiveCell.Offset(0, -4).Value = ActiveCell.Offset(1, -4).Value & "P"
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Wend
Range("A1").Select
End Sub
I have the following code which highlights contiguous and non-contiguous cells that have the same contents in a single column with different colours. Could this code be modified to highlight only contiguous cells in one column with one colour (e.g. yellow)?
Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
Dim rngCellB As Range
Dim colValue As New Collection
Dim intColor As Integer
Set rngArea = ActiveSheet.Range("F1:F65536")
intColor = 5
On Error Resume Next
For Each rngCellA In rngArea
If rngCellA.Value <> "" Then
Err.Clear
colValue.Add rngCellA.Value, "MB" & rngCellA.Value
If Err = 0 Then
intColor = intColor + 1
For Each rngCellB In rngArea
If rngCellB.Value = rngCellA.Value Then
rngCellB.Interior.ColorIndex = intColor
End If
Next rngCellB
End If
End If
Next rngCellA
End Sub
Assistance with this matter is highly appreciated. Thanks in advance.
The below code will highlight all non-blank and duplicate values for all cells in columns B through F:
Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
Dim rngCellB As Range
'Narrow the search area to only that which has been used
Set rngArea = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:F"))
For Each rngCellA In rngArea
'No point in searching for blank cells or ones that have already been highlighted
If Not rngCellA.Value = vbNullString And Not rngCellA.Interior.Color = vbYellow Then
Set rngCellB = rngArea.Find(What:=rngCellA.Value, LookAt:=xlWhole, After:=rngCellA)
'Check if the value in rngCellA exists anywhere else
If Not rngCellB Is Nothing And Not rngCellB.Address = rngCellA.Address Then
'If another does exist, highlight it and every value that duplicates it
rngCellA.Interior.Color = vbYellow
Do While Not rngCellB.Address = rngCellA.Address
rngCellB.Interior.Color = vbYellow
Set rngCellB = rngArea.Find(What:=rngCellA.Value, LookAt:=xlWhole, After:=rngCellB)
Loop
End If
End If
Next rngCellA
End Sub
To only evaluate contiguous cells in the same column I would modify the code as such:
Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
'Narrow the search area to only that which has been used
Set rngArea = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:F"))
For Each rngCellA In rngArea
'No point in searching for blank cells or ones that have already been highlighted
If Not rngCellA.Value = vbNullString And Not rngCellA.Interior.Color = vbYellow Then
If rngCellA.Offset(-1, 0).Value = rngCellA.Value Then
rngCellA.Offset(-1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
If rngCellA.Offset(1, 0).Value = rngCellA.Value Then
rngCellA.Offset(1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
End If
Next rngCellA
End Sub
This is what coding at 2am gets you with no sleep. =)
I was missing the all important Not in (Not rngCellA.Interior.Color = vbYellow). Also I noticed that I forgot to highlight the first cell identified.
I have retested both code segments and both are now working as intended.
Segment 1 will highlight anything that is duplicated within columns B through F.
Segment 2 will highlight anything that is duplicated only that is contiguous and in the same column.
If your data table starts in row 1 (No header) or goes to the last row available on the sheet:
If Not rngCellA.Row = 1 Then
If rngCellA.Offset(-1, 0).Value = rngCellA.Value Then
rngCellA.Offset(-1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
End If
If Not rngCellA.Row = ActiveSheet.Rows.Count Then
If rngCellA.Offset(1, 0).Value = rngCellA.Value Then
rngCellA.Offset(1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
End If
I have one file with two worksheets, both are full of names and addresses. I need a macro that will highlight rows in the first sheet if the cell A of that row does not match any rows from column A of the second sheet.
So if the first cell in a row has no matching data in any of the data in column A of sheet2 then that row is highlighted red.
Also I might want to expand this in the future so could I also specify that Sheet1 can be the active sheet, but sheet2 is called by the sheet name?
Try below code :
Sub Sample()
Dim lastRow As Integer
Dim rng As Range
lastRow = Sheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 1 To lastRow
Set rng = Sheets("sheet2").Range("A:A").Find(Sheets("Sheet1").Cells(i, 1))
If rng Is Nothing Then
Sheets("Sheet1").Cells(i, 1).EntireRow.Interior.Color = vbRed
End If
Next
End Sub
Here's an ugly brute-force approach:
Dim r As Range
Dim s As Range
For Each r In ActiveSheet.UsedRange.Rows
For Each s In Sheets("Sheet2").UsedRange.Rows
If r.Cells(1, 1).Value = s.Cells(1, 1).Value Then
r.Interior.ColorIndex = 3
End If
Next s
Next r
Here's a slicker way:
Dim r As Range
Dim s As Range
Set s = Sheets("Sheet2").Columns(1)
For Each r In ActiveSheet.UsedRange.Rows
If Not (s.Find(r.Cells(1, 1).Value) Is Nothing) Then
r.Interior.ColorIndex = 3
End If
Next r
how about this:
Sub CondFormatting()
Range("D1:D" & Range("A1").End(xlDown).Row).Formula = "=IF(ISERROR(VLOOKUP(A:A,Sheet2!A:A,1,FALSE)),""NOT FOUND"",VLOOKUP(A:A,Sheet2!A:A,1,FALSE))"
With Columns("D:D")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""NOT FOUND"""
.FormatConditions(1).Interior.ColorIndex = 3
End With
Range("I16").Select
End Sub
here is an approach using a Worksheet formula:
=IF(ISERROR(VLOOKUP(A:A,Sheet2!A:A,1,FALSE)),"NOT FOUND",VLOOKUP(A:A,Sheet2!A:A,1,FALSE))
then you would use Conditional formatting to turn the cells red if column A doesn't find a match!
HTH
Philip