I need to compare two values and highlight the difference if any.
The below snippet is saying equal or not but along with that I need to highlight the values.
Cells contains a list of string values.
Public Sub Overview_LRF()
If (Range("L2").Value = Range("L5").Value) Then
Gazellevalidation2.OverviewProjects.Value = "Equals"
Else
Gazellevalidation2.OverviewProjects.Value = "Not Equals"
End If
End Sub
Sub HighlightDuplicateValues()
Dim myRange As Range
Dim myCell As Range
Set myRange = Selection
For Each myCell In myRange
If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 36
End If
Next myCell
End Sub
On the same lines, made a macro to find difference in two cells by checking character by character. Some times this kind of situations do occur, where we need to find out the difference by character.
Paste data in adjacent columns, like col A, Col B
Data in Col A and B will be same like A1="David",B1="Davi1d", with a difference.
Select first column and run the macro
Macro will check thecell and the adjacent cell and highlight the difference.
Sub ChkDiff()
i = ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
Set myRange = Selection
For Each Cell In myRange
L1 = Len(Cell.Value)
L2 = Len(Cell.Offset(0, 1).Value)
If L1 > L2 Then
LENT = L1
Else
LENT = L2
End If
'Cells(j, ActiveCell.Column).Select
For x = 1 To LENT
v1 = Cell.Characters(1, x).Text
v2 = Cell.Offset(0, 1).Characters(1, x).Text
If v1 <> v2 Then
Cell.Characters(x, 1).Font.Color = VBA.RGB(255, 0, 0)
End If
Next x
Next
End Sub
See this example below:
Option Explicit
Sub main()
Dim in1 As Range
Dim in2 As Range
Dim out As Range
Dim i As Long
Dim iLen As Long
Set in1 = Cells(1, 1)
Set in2 = Cells(1, 2)
Set out = Cells(1, 3)
If in1.Value2 = in2.Value2 Then
out = "<identical>"
Else
out.Value2 = vbNullString
iLen = Len(in1.Value2)
For i = 1 To iLen ' find the 1st mismatch
If in1.Characters(i, 1).Text <> in2.Characters(i, 1).Text Then Exit For
Next i
If i <= iLen Then
out.Value2 = in1.Value2
Else
out.Value2 = in2.Value2
iLen = Len(in2.Value2)
End If
out.Characters(i, iLen - i + 1).Font.Color = vbRed
' you can make it more robust here
' handling nullstring output or space char
End If
End Sub
If you need more sophisticated comparison, you might consider Fuzzy Lookup Add-In for Excel.
Related
I have been searching for a while now a code to help me to extract superscript characters (number 1 and 2) that are either in the middle or at the end of a string in column A. I need to cut them from the string and paste them into the same row, but on column C as a normal number.
I did not find any suitable solutions I could evev try. So I do not have any code because I do not know where to start. My data will have always less than 500 lines and has the same structure, but lines with superscript change.
Does anyone know to solve this problem please? Thanks a lot.
I would really appreciate the help.
Desired output: for every row where there is a superscript, cut it from string in Column A and paste it in column C as a normal number..
Sub extractSuperscript()
Dim rng As Range
Dim cell As Range
Dim i As Long
Dim j As Long
Dim result As String
' Define the range to process
Set rng = Range("A1:A10")
' Loop through each cell in the range
For i = 1 To rng.Cells.Count
Set cell = rng.Cells(i)
result = ""
' Loop through each character in the cell
For j = 1 To Len(cell.Value)
' Check if the character is a superscript 1 or 2
If Mid(cell.Value, j, 1) = "¹" Or Mid(cell.Value, j, 1) = "²" Then
' If the character is a superscript 1, add a 1 to the result string
If Mid(cell.Value, j, 1) = "¹" Then
result = result & "1"
' If the character is a superscript 2, add a 2 to the result string
ElseIf Mid(cell.Value, j, 1) = "²" Then
result = result & "2"
End If
End If
Next j
' Paste the result string into column C and remove the superscript from column A
cell.Offset(0, 2).Value = result
cell.Value = Replace(cell.Value, "¹", "")
cell.Value = Replace(cell.Value, "²", "")
Next i
End Sub
Let me know if this works
Let me know if the following works:
Option Explicit
Sub Superscript()
Application.ScreenUpdating = True
Dim wb As Workbook
Dim ws As Worksheet
Dim rngSuperscript As Range, c As Range
Dim iCount As Integer
Dim MyString As String
Set wb = ThisWorkbook
'Set it to sheet name where your data is
Set ws = wb.Sheets("Test")
'Change it to reflect your data
Set rngSuperscript = ws.Range("A2:A11")
For Each c In rngSuperscript
'temp text variable
MyString = c.Value
'loop through the string value
For iCount = 1 To Len(MyString)
'check if it is numeric
If IsNumeric(Mid(MyString, iCount, 1)) Then
'combine with the C column value (if any)
c.Offset(0, 2).Value = CLng(c.Offset(0, 2).Value & Mid(MyString, iCount, 1))
End If
Next
Next c
Application.ScreenUpdating = False
End Sub
I am working on an Excel document using VBA. This document contains a database with multiple columns, but for simplicity, let's say I have 2 columns:
Column C corresponds to names
Column F corresponds to numbers.
I'm trying to create a macro that checks all the numbers in column F (with a loop). If the number is above 100, then check the adjacent cell in column C. If the name corresponds to a condition (let's say corresponds to John or Tom), then add the value of the number in another sheet. If none of those apply, check the next cell.
My problem is that I can't find a way to define the cells in column C (Creating a variable/object to call the cells or calling directly the adjacent cell).
My code looks like this:
Sub Test1()
Dim rngnumbers, rngnames, MultipleRange As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
Else
End If
End If
Next numb
End Sub
I tried modifying the line:
'If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then'
to something like:
'newname.String = "John" '
But I can't find a way to define newname.
Another idea would be to increment the If statement for the names within the For loop.
Additional note:
I am also not using formulas directly within Excel as I don't want any blank cells or zeros when the if functions are False.
Does this solve your problem - referencing the relevant cell in column C? OFFSET provides a relative reference, in this case look 3 columns to the left of F.
Sub Test1()
Dim rngnumbers As Range, rngnames As Range, MultipleRange As Range, numb As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If numb.Offset(, -3) = "John" Or numb.Offset(, -3) = "Tom" Then
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
End If
End If
Next numb
End Sub
Have you considered SUMIFS instead?
You want something like this?
Sub Test1()
Dim lRow As Long, r As Long
lRow = 1000 'last row in your data
Dim ws As Worksheet
Set ws = Worksheets("List with your data")
For i = 2 To lRow
If ws.Range("F" & i) > 100 Then
If ws.Range("C" & i).Value = "John" Or ws.Range("C" & i).Value = "Tom" Then
Worksheets("Another sheet sheet").Range("A" & r) = Range("C" & i).Value ' r - Row, where we want to enter uor text
r = r + 1 'if you want to put next name on the next row
End If
End If
Next
End Sub
Two Ifs in a Loop
Union Version
Option Explicit
Sub Test1()
Const cFirst As Integer = 2
Const cLast As Integer = 999
Const cCol1 As Variant = "F"
Const cCol2 As Variant = "C"
Const cCol3 As Variant = "I"
Dim i As Integer
Dim rngU As Range
With Sheet2
For i = cFirst To cLast
If IsNumeric(.Cells(i, cCol1)) And .Cells(i, cCol1) >= 100 Then
If .Cells(i, cCol2) = "John" _
Or .Cells(i, cCol2) = "Tom" Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, cCol1))
Else
Set rngU = .Cells(i, cCol1)
End If
End If
End If
Next
End With
If Not rngU Is Nothing Then
rngU.Copy Sheet1.Cells(cLast, cCol3).End(xlUp).Offset(1, 0)
Set rngU = Nothing
End If
End Sub
I normally work with arrays:
Sub Test1()
Dim rngnumbers As Excel.Range
Dim arrVals As variant
Dim lngRow As long
Arrvals = Sheet2.Range("C2:F999").value
For Lngrow = lbound(arrvals,1) to ubound(arrvals,1)
If arrvals(lngrow,4) >= 100 Then
If arrvals(lngrow,1)= "John" Or arrvals(lngrow,1) = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = arrvals(lngrow,4)
Else
End If
End If
Next lngrow
End Sub
Actually I would probably build an output array as well, but my thumb is tired...
When the following code runs, it doesn't complete in its entirety. I usually have to run it a few more times to ensure all the data in that range has been inspected and the row deleted if it meets my criteria.
Const A% = 1
Const B% = 2
Const C% = 3
Const D% = 4
'Some code
If myCL <> "" Then
For Each Cell In RngB.Cells
If Cell.Value <= myBal Then
r = Cell.Row
If ws.Cells(r, D) <= myScore And ws.Cells(r, C) Like myCL Then
Cell.EntireRow.Delete
End If
End If
Next Cell
ElseIf myCL = "" Then
For Each Cell In RngB.Cells
If Cell.Value <= myBal Then
r = Cell.Row
If ws.Cells(r, D) <= myScore Then
Cell.EntireRow.Delete
End If
End If
Next Cell
End If
I understand that I should loop through a range in reverse when using something like For i = ## to 1 Step -1, but I don't believe this would apply in this situation.
My issue is that when Cell should meet the criteria, it sometimes skips over it, which I then rerun the code and it will be deleted.
Another method is, instead of adding the rows to an array, or looping backwards and deleting the rows one by one, is to define a DelRng as a Range object.
Everytime, you pass your criteria, than you add that Row to the DelRng object, using the Union function, and at the end, you delete DelRng with one-shot.
Code
Dim DelRng As Range ' new range object, collects all rows that needs to be deleted
If myCL <> "" Then
For Each Cell In RngB.Cells
If Cell.Value <= myBal Then
r = Cell.Row
If ws.Cells(r, D) <= myScore And ws.Cells(r, C) Like myCL Then
' add current row to DelRng
If Not DelRng Is Nothing Then
Set DelRng = Application.Union(DelRng, .Rows(r))
Else
Set DelRng = .Rows(r)
End If
End If
End If
Next cell
ElseIf myCL = "" Then
For Each Cell In RngB.Cells
If Cell.Value <= myBal Then
r = Cell.Row
If ws.Cells(r, D) <= myScore Then
' add current row to DelRng
If Not DelRng Is Nothing Then
Set DelRng = Application.Union(DelRng, .Rows(r))
Else
Set DelRng = .Rows(r)
End If
End If
End If
Next cell
End If
' now delete the entire rows at once (will save you a lot of run-time)
If Not DelRng Is Nothing Then DelRng.Delete
You're pulling the rug under the For Each statement by deleting the row it is iterating on (For Each scans left to right, from the top row to the bottom row). Excel is nice enough to resume the iteration at "next" cell, which really is located on the row after the one it just deleted, and typically 1 cell to the right. But then, your code missed all of the leftmost cells on the new current row, some of which may fulfill your criteria.
Edit
The issue can be circumvented by somehow taking note of the rows to delete, without deleting them within the For Each loop. My personal favorite way of doing so is to use a Scripting.Dictionary, as demonstrated below:
Sub ForEachWithRowDeleteDemo()
Dim rangeOfInterest As Excel.Range
Dim cell As Excel.Range
Dim dicRowIndexesToDelete As Object 'Scripting.Dictionary
Dim rowIndex As Variant
Set rangeOfInterest = Sheet1.Range("A1:Z10") 'ASSUMPTION: rangeOfInterest is a contiguous range; no checks are made here.
Set dicRowIndexesToDelete = CreateObject("Scripting.Dictionary")
For Each cell In rangeOfInterest.Cells
If cell.Value2 = 123 Then '...your conditions go here.
'Cumulate distinct row indexes.
dicRowIndexesToDelete(cell.Row - rangeOfInterest.Row + 1) = True
End If
Next
If dicRowIndexesToDelete.Count > 0 Then
If rangeOfInterest.Cells.Count = 1 Then
'Exceptional case: rangeOfInterest is a single cell.
rangeOfInterest.EntireRow.Delete
Else
'Mark each of the range's rows.
rangeOfInterest.Clear
For Each rowIndex In dicRowIndexesToDelete.Keys
rangeOfInterest.Cells(rowIndex, 1) = True
Next
'Find the marks and delete the entire rows.
rangeOfInterest.SpecialCells(xlCellTypeConstants).EntireRow.Delete
End If
End If
Set dicRowIndexesToDelete = Nothing
Set cell = Nothing
Set rangeOfInterest = Nothing
End Sub
Notice that all rows are deleted at once, for better performance. This will only work if there are no more than 8'192 separate "islands" of rows to delete; beyond that, the SpecialCells method would fail. The exceptional case of a single cell range of interest must be handled separately, since SpecialCells will consider the whole worksheet as its search zone if applied to a single cell.
This is a proof of concept that should work around the problem you're facing. Instead of deleting the rows in your For Loops, you could assign the Row to a 1-dimensional Array, then build a string and delete the rows all at once outside of your Loop.
Run this on a sheet with the first 7 rows filled out, then hit play and watch.
Sub DeletingRows()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim myArr(0 To 2) As Long
Dim myStr As String
myArr(0) = 2
myArr(1) = 4
myArr(2) = 6
For Each myRow In myArr
myStr = myStr & myRow & ":" & myRow & ","
Next myRow
myStr = Left(myStr, Len(myStr) - 1)
ws.Range(myStr).EntireRow.Delete
End Sub
How to integrate this into your code
Where x is a long starting at 0.
If myCL <> "" Then
For Each Cell In RngB.Cells
If Cell.Value <= myBal Then
r = Cell.Row
If ws.Cells(r, D) <= myScore And ws.Cells(r, C) Like myCL Then
myArr(x) = Cell.Row
x = x + 1
End If
End If
Next Cell
ElseIf myCL = "" Then
For Each Cell In RngB.Cells
If Cell.Value <= myBal Then
r = Cell.Row
If ws.Cells(r, D) <= myScore Then
myArr(x) = Cell.Row
x = x + 1
End If
End If
Next Cell
End If
For Each myRow In myArr
myStr = myStr & myRow & ":" & myRow & ","
Next myRow
myStr = Left(myStr, Len(myStr) - 1)
ws.Range(myStr).Delete
In Excel, I've written a short script that should remove the first character of each cell containing a "*"symbol at the start of it. What I have so far is
Sub Macro5()
Dim Rng As Range
Dim i As Long
i = 1
While i <= 20000
Set Rng = Range("A" & i)
If InStr(Rng, "*") > 0 Then
Rng.Offset(0, 1).Formula = "=Right(Rng,LEN(Rng)-1)"
i = i + 1
Else: i = i + 1
End If
Wend
End Sub
The line to call the script seems to work, but the formula getting placed into column B is "=Right(Rng,LEN(Rng)-1)", which gives a 'NAME?' error. How do I define the LEN formula to use Rng as a range, rather than as a 'word' on the spreadsheet?
Using R1C1 type formulae makes life much easier in that situation.
Sub RemoveFirstStar()
Dim rng As Range, c As Range
Set rng = Range("A1:A2000")
For Each c In rng.Cells
If Left(c, 1) = "*" Then
c.Offset(0, 1).FormulaR1C1 = "=mid(rc[-1],2,1000)"
End If
Next c
End Sub
For your particular code example, change the line after the IF:
Rng.Offset(0, 1).FormulaR1C1 = "=Right(RC[-1],LEN(RC[-1])-1)"
I have column A with staff ids and hours worked in column K.
I would like if a staff id appears more than once to add hours worked and put the result in another column corresponding to the first instance of that staff id and the duplicates being 0.
This is for a monthly report and there may be over 2k records at any point.
As everyone else said, a Pivot Table really is the best way. If you're unsure how to use a PivotTable or what it's good for, refer to this SO post where I explain in detail.
Anyway, I put together the below VBA function to help get you started. It's by no means the most efficient approach; it also makes the following assumptions:
Sheet 1 has all the data
A has Staff Id
B has Hours
C is reserved for Total Hours
D will be available for processing status output
This of course can all be changed very easily by altering the code a bit. Review the code, it's commented for you to understand.
The reason a Status column must exist is to avoid processing a Staff Id that was already processed. You could very alter the code to avoid the need for this column, but this is the way I went about things.
CODE
Public Sub HoursForEmployeeById()
Dim currentStaffId As String
Dim totalHours As Double
Dim totalStaffRows As Integer
Dim currentStaffRow As Integer
Dim totalSearchRows As Integer
Dim currentSearchRow As Integer
Dim staffColumn As Integer
Dim hoursColumn As Integer
Dim totalHoursColumn As Integer
Dim statusColumn As Integer
'change these to appropriate columns
staffColumn = 1
hoursColumn = 2
totalHoursColumn = 3
statusColumn = 4
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
totalStaffRows = Sheet1.Cells(Rows.Count, staffColumn).End(xlUp).Row
For currentStaffRow = 2 To totalStaffRows
currentStaffId = Cells(currentStaffRow, staffColumn).Value
'if the current staff Id was not already processed (duplicate record)
If Not StrComp("Duplicate", Cells(currentStaffRow, statusColumn).Value, vbTextCompare) = 0 Then
'get this rows total hours
totalHours = CDbl(Cells(currentStaffRow, hoursColumn).Value)
'search all subsequent rows for duplicates
totalSearchRows = totalStaffRows - currentStaffRow + 1
For currentSearchRow = currentStaffRow + 1 To totalSearchRows
If StrComp(currentStaffId, Cells(currentSearchRow, staffColumn), vbTextCompare) = 0 Then
'duplicate found: log the hours worked, set them to 0, then mark as Duplicate
totalHours = totalHours + CDbl(Cells(currentSearchRow, hoursColumn).Value)
Cells(currentSearchRow, hoursColumn).Value = 0
Cells(currentSearchRow, statusColumn).Value = "Duplicate"
End If
Next
'output total hours worked and mark as Processed
Cells(currentStaffRow, totalHoursColumn).Value = totalHours
Cells(currentStaffRow, statusColumn).Value = "Processed"
totalHours = 0 'reset total hours worked
End If
Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End Sub
BEFORE
AFTER
Here is the solution for the data table located in range A1:B10 with headers and results written to column C.
Sub Solution()
Range("c2:c10").Clear
Dim i
For i = 2 To 10
If WorksheetFunction.SumIf(Range("A1:a10"), Cells(i, 1), Range("C1:C10")) = 0 Then
Cells(i, "c") = WorksheetFunction.SumIf( _
Range("A1:a10"), Cells(i, 1), Range("B1:B10"))
Else
Cells(i, "c") = 0
End If
Next i
End Sub
Try below code :
Sub sample()
Dim lastRow As Integer, num As Integer, i As Integer
lastRow = Range("A65000").End(xlUp).Row
For i = 2 To lastRow
num = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & lastRow), 0)
If i = num Then
Cells(i, 3) = WorksheetFunction.SumIf(Range("A1:A" & lastRow), Cells(i, 1), Range("B1:B" & lastRow))
Else
Cells(i, 1).Interior.Color = vbYellow
End If
Next
End Sub
BEFORE
AFTER
Below code identifies duplicate value in a column and highlight with red. Hope this might be of some help.
iLastRow = Cells(chosenExcelSheet.Rows.Count, 1).End(xlUp).Row 'Determine the last row to look at
Set rangeLocation = Range("A1:A" & iLastRow)
'Checking if duplicate values exists in same column
For Each myCell In rangeLocation
If WorksheetFunction.CountIf(rangeLocation, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3'Highlight with red Color
Else
myCell.Interior.ColorIndex = 2'Retain white Color
End If
Next
Sub SelectColoredCells()
Dim rCell As Range
Dim lColor As Long
Dim rColored As Range
'Select the color by name (8 possible)
'vbBlack, vbBlue, vbGreen, vbCyan,
'vbRed, vbMagenta, vbYellow, vbWhite
lColor = RGB(156, 0, 6)
'If you prefer, you can use the RGB function
'to specify a color
'Default was lColor = vbBlue
'lColor = RGB(0, 0, 255)
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = lColor Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
If rColored Is Nothing Then
MsgBox "No cells match the color"
Else
rColored.Select
MsgBox "Selected cells match the color:" & _
vbCrLf & rColored.Address
End If
Set rCell = Nothing
Set rColored = Nothing
End Sub
this highlights the duplicates