I have a list of addresses and parts of the addresses for some records have been duplicated. e.g. some records contain "London" in both column D and column E.
I want to find and highlight any duplicate values across all columns, but within the same row.
So far I have written the code below, but I want it to work through every column containing values and not just the two columns I have named.
Dim Lastrow As Long
Dim i As Long
Lastrow = Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Range("D" & i).Value = Range("E" & i).Value Then
Range("E" & i).Interior.ColorIndex = 6
End If
Next i
I have tried to search for an answer, but I have only been able to find ways of highlighting entire duplicate rows or duplicate values in different columns and rows.
Thank you for taking the time to read this and for any help you can give.
If you really want a VBA Solution this does the trick:
Sub JustCall()
Call DuplicatedInRangeByRow(Range("A1:D5"))
End Sub
Sub DuplicatedInRangeByRow(RangeToLook As Range)
Const ColorHighlight = vbYellow
Dim ItemRange As Range
Dim TotalRows As Long: TotalRows = IIf(RangeToLook.Row > 1, RangeToLook.Rows.Count + RangeToLook.Row - 1, RangeToLook.Rows.Count)
Dim TotalCols As Long: TotalCols = IIf(RangeToLook.Column > 1, RangeToLook.Columns.Count + RangeToLook.Column - 1, RangeToLook.Columns.Count)
Dim CounterCols As Long
Dim CounterRows As Long
Dim StartCol As Long
Dim SheetForRange As Worksheet: Set SheetForRange = RangeToLook.Parent
For CounterRows = RangeToLook.Row To TotalRows
For CounterCols = RangeToLook.Column To TotalCols
StartCol = IIf(StartCol = 0, CounterCols, StartCol)
With SheetForRange
If CStr(.Cells(CounterRows, StartCol).Value) = CStr(.Cells(CounterRows, CounterCols).Value) And StartCol <> CounterCols Then .Cells(CounterRows, StartCol).Interior.Color = ColorHighlight: .Cells(CounterRows, CounterCols).Interior.Color = ColorHighlight
End With
Next CounterCols
StartCol = 0
Application.StatusBar = "Progress: " & CounterRows & " out of " & TotalRows & " Rows analyzed " & Format(CounterRows / TotalRows, "Percent")
Next CounterRows
End Sub
for conditional formatting you would use the following formula:
=COUNTIF($A1:$J1,A1)>1
Where $A1 and A1 refers to the most upper left cell in the range to which the formatting is being applied. And the $J1 is the upper right cell of the range.
Pay close attention to what is absolut and what is relative.
Related
Please see an abstracted example in the image below
Warning! I'm very new to VBA and still learning, so there might be some obvious mistakes in my code.
I have a very large table of data containing several rows and columns. The objective is to loop through a column containing a bunch of IDs and detect duplicates in a specific segment of the string. As soon as there is a mismatch in this segment, the row and new value is stored before a reverse loop begins that shifts everything below down the last duplicate down by four spaces.
The result is three blank rows after all duplicates (see image).
There's a few conditions that I have to meet for this code to be compatible with the software that secures this sheet:
Inserting whole rows needs to be avoided, insert and shift down is okay
Avoiding select is ideal
No application enable/disable can be used
The fewer individual cell changes the better
The idea is to loop through each of the columns to shift all corresponding values in that row down once I have perfected the first column. It would be great to avoid having to do so if there's a way to shift the whole range down instead of individual cells.
The second, reverse loop seems to be the problem.
I've tried several ways of looping using integer loops, range for loops, do while, and do until.
Please let me know if you need clarification! Thank you so much for your help.
Sub shiftValues()
Dim ws1 As Worksheet
Set ws1 = Worksheets("Tab1=Raw Data")
Dim lastRow As Variant
lastRow = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
Dim cell As Range
Dim rng As Range
Set rng = ws1.Range("A16:A" & lastRow)
Dim oldString As String
Dim newString As String
newString = "newString"
Dim oldRow As Integer
oldRow = 15 'Start of table
Dim beforeEqual() As String
beforeEqual = Split(ws1.Range("A15").Value, "=")
Dim tar As Long
For Each cell In rng
oldString = Right(beforeEqual(0), 2)
If cell.Value <> vbNullString And Len(cell.Value) > 6 Then
beforeEqual = Split(cell.Value, "=")
newString = Right(beforeEqual(0), 2)
If newString <> oldString And cell.Row > 15 Then
oldString = newString
oldRow = cell.Row
tar = lastRow
Do Until tar = oldRow
Range("A" & tar + 4).Value = Range("A" & tar).Value
Range("A" & tar).ClearContents
tar = tar - 1
Loop
End If
End If
Next cell
End Sub
This may do what you want:
j = 0
For i = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
If Range("A" & i).Value <> Range("A" & i - 1).Value And Range("A" & i - 1).Value <> Range("A" & i - 2).Value Then
If j = 0 Then
j = i
Else
End If
Else
If j > 0 Then
Range("A" & i & ":A" & i + 2).Insert Shift:=xlDown
j = 0
End If
End If
I wanted to convert below formula to VBA code.
=C1&"`"&K1&"`"&L1&"`"&J1
=VLOOKUP(M1,Data!$A:$J,9,)
=SUMPRODUCT(SUMIF(B1:B,B1,G1:G))
Currently i have enter this formula in 1st row and than copying this formula till the last row used which is taking lot time to apply formula because it has more than million row.
LR1 = Sheets("CRIMS").UsedRange.Rows.Count
Sheets("CRIMS").Range("M1:P1").AutoFill Destination:=Sheets("CRIMS").Range("M1:P" & LR1)
is there any way to convert this formula into VBA code?
For first formula the easiest way would be:
Range("M" & i).FormulaR1C1 = "=RC[-10]&""`""&K&""`""&L&""`""&J"
But for vlookup I prefer dictionaries/collections! It is much much faster.
If You have source data in Data sheet and You want to put that to CRIMS sheet to column M:
Sub vlookup()
Dim names As Range, values As Range
Dim lookupNames As Range, lookupValues As Range
Dim vlookupCol As Object
Dim lastRow As Long
Dim lastRow2 As Long
Dim objekt as Object
With Sheets("Data")
lastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).row
Set names = Sheets("Data").Range("A1:A" & lastRow)
Set values = Sheets("Data").Range("I1:A" & lastRow)
End With
Set objekt = BuildLookupCollection(names, values)
With Sheets("CRIMS")
lastRow2 = 1000000
Set lookupNames = .Range("M1:M" & lastRow)
Set lookupValues = .Range("N1:N" & lastRow)
End With
VLookupValues lookupNames, lookupValues, objekt
Set objekt = Nothing
End Sub
Function BuildLookupCollection(categories As Range, values As Range)
Dim vlookupCol As Object, i As Long
Set vlookupCol = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 1 To categories.Rows.Count
Call vlookupCol.Add(CStr(categories(i)), values(i))
Next i
On Error GoTo 0
Set BuildLookupCollection = vlookupCol
End Function
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
Dim i As Long, resArr() As Variant
ReDim resArr(lookupCategory.Rows.Count, 1)
For i = 1 To lookupCategory.Rows.Count
resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
Next i
lookupValues = resArr
End Sub
Quotation Marks need to be doubled in VBA
Try this:
For i = 1 To LR1
Range("M" & i).Formula = "=C" & i & "&""`""&K" & i & "&""`""&L" & i & "&""`""&J" & i
Range("N" & i).Formula = "=VLOOKUP(M" & i & ",Data!$A:$J,9,)"
Next i
(replace column letters with actual target column)
As mentioned in the comments Looping in this case is highly inefficient.
Use this Code to insert the formulas all at once. It still takes some time for 1 Milion rows though.
Range("M1:M" & LR1).Formula = "=C:C & ""`"" & K:K & ""`"" & L:L & ""`"" & J:J"
Range("N1:N" & LR1).Formula = "=VLOOKUP(M:M,Data!$A:$J,9,)"
The IDs column in the first table contains multiple values in each cell that needs to be split. However, the unique issue is to retain both [name] and [description] info by ID into a new table.
.
The following VBA code performs the transpose paste option. This is what I am starting with to split cells with Chr(10), or new line as the delimiter:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
End Sub
Other than this, I am still searching for ideas.
Maybe this will help:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim lngRow As Long, lngEl As Long
With Sheet2
'Range A2:A5
For lngRow = 5 To 2 Step -1
splitVals = Split(.Range("A" & lngRow).Value, Chr(10))
'the first value
.Range("A" & lngRow).Value = splitVals(0)
'remaining values
For lngEl = 1 To UBound(splitVals)
.Rows(lngRow + lngEl).Insert
.Range("A" & lngRow + lngEl).Value = splitVals(lngEl)
.Range("B" & lngRow + lngEl & ":C" & lngRow + lngEl).Value = .Range("B" & lngRow & ":C" & lngRow).Value
Next lngEl
Next lngRow
End With
End Sub
Change Sheet Code/Name and Range as necessary.
Before:
After:
It's a bit more involved than your solution because you have to insert the correct number of rows below the targeted cell and then copy the IDs and the other data into the new rows. Here's an example to help you along.
There's a little "trickery" I'm using when I calculate the offset value. I'm doing this because you can assume that all arrays from the Split function will begin indexing at 0, but my personal habit is to write code that can work with either a 0 or 1 lower bound. Calculating and using an offset makes it all work for the loops and indexes.
Option Explicit
Sub test()
SplitText ActiveCell
End Sub
Sub SplitText(ByRef idCell As Range)
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(idCell.Value, Chr(10))
If LBound(splitVals) = -1 Then
'--- the split character wasn't found, so exit
Exit Sub
End If
Dim offset As Long
offset = IIf(LBound(splitVals) = 0, 1, 0)
totalVals = UBound(splitVals) + offset
Dim idSheet As Worksheet
Set idSheet = idCell.Parent
Dim idRow As Long
idRow = idCell.Row
'--- insert the number of rows BELOW the idCell to hold all
' the split values
Dim i As Long
For i = 1 To totalVals - 1
idSheet.Rows(idRow + 1).Insert
Next i
'--- now add the IDs to all the rows and copy the other columns down
Const TOTAL_COLUMNS As Long = 3
Dim j As Long
Dim startIndex As Long
startIndex = LBound(splitVals) + offset
For i = startIndex To totalVals
idCell.Cells(i, 1) = splitVals(i - offset)
For j = 2 To TOTAL_COLUMNS
idCell.Cells(i, j) = idCell.Cells(1, j)
Next j
Next i
End Sub
Forgive me, as this may be very simple. I am trying to create a VBA macro that quickly gets statistics from raw data and puts them in a table. The raw data comes in this format:
(They will not always be in groups of three)
How would I get the range for all of a category, and then use that same range for Columns B and C to get the statistics I need?
The below code get you the row numbers of each category and assumes there is no break in content on column B, your question was to get the content of columns C:D by category, having these row values will enable you to code to get the content of C:D.
Public Sub Sample()
Dim WkSht As Worksheet
Dim StrCategory As String
Dim LngRow As Long
Dim LngRowStart As Long
Set WkSht = ThisWorkbook.Worksheets("RawData")
'Take note of the category we are one
StrCategory = WkSht.Range("A" & 2).Value
'Take not of the row the category started on
LngRowStart = 2
'Look to the next row
LngRow = 3
'Loop through the data until column B has no value, signifying the end of the dataset
Do Until WkSht.Range("B" & LngRow) = ""
'Go to the next row until we are given a new category or make it to the end of the dataset
Do Until (WkSht.Range("A" & LngRow) <> "") Or (WkSht.Range("B" & LngRow) = "")
LngRow = LngRow + 1
Loop
'Talk in the immediate pane
Debug.Print StrCategory & " is on rows " & LngRowStart & " to " & LngRow - 1
'Get the next values
StrCategory = WkSht.Range("A" & LngRow)
LngRowStart = LngRow
'Move on
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
End Sub
Below is the input data I gave it: -
Below is the output from the code: -
You could use some If statements and pull this all into an array, but it seems more direct to just fill in the blanks
Sub FillColA()
Dim LastRow As Long
LastRow = Application.WorksheetFunction.CountA(Range("B:B"))
Range("A2:A" & LastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I'm looping through a table (Sheet4) in a worksheet and inserting an empty column between each original column. In the new, empty columns, I want to insert a VLookup function.
I has successfully inserted the columns and I have successfully held the proper range (proper number of rows too) in a variable called FormulaRange.
I'm having problems with the VLookup. I don't know if it's the way I'm storing my variables or if I need to have a paste function after my Vlookup. Can someone take a look and give me a hand?
*note - I stored FormulaRange as String becuase As Range wouldn't let me pass my code into the variable. As a result I can't use the FormulaRange.Formula Method.
If I were to manually input the VLookup I would write it as =VLOOKUP(B1,RosettaStone_Employees!$A$1:$B$5,2,FALSE) and then copy down the range.
Sub InsertColumnsAndFormulasUntilEndOfProductivityTable()
Dim ActivityRange As Range
Dim UserName As String
Dim FormulaRange As String
Dim i As Integer
Dim x As Long
Dim y As Long
Dim Startrow As String
Dim Lastrow As String
Sheet6.Activate
Set ActivityRange = Range("A1", Range("B1").End(xlDown))
Sheet4.Activate
Range("A1").Select
y = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row - 1
x = (Sheet4.Cells(1, Columns.Count).End(xlToLeft).Column) * 2
For i = 1 + 2 To x Step 2
Columns(i).EntireColumn.Insert
Startrow = 2
Lastrow = y
UserName = Cells(1, i - 1)
FormulaRange = Cells(Startrow, i).Address & ":" & Cells(Lastrow + 1, i).Address
FormulaRange = "=VLookup(UserName, ActivityRange, 2, False)"
Next
End Sub
Thanks
Jonathan
I changed your code a little to get rid of the sheet activates. Also I changed a few things to ranges and included with blocks.
This is untested:
Sub InsertColumnsAndFormulasUntilEndOfProductivityTable()
Dim ActivityRange As Range
Dim UserName As String
Dim FormulaRange As Range
Dim i As Long
Dim x As Long
Dim y As Long
Dim Startrow As Long
Dim Lastrow As Long
With Sheet6
Set ActivityRange = .Range("A1", .Range("B1").End(xlDown))
End With
With Sheet4
y = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
x = (.Cells(1, .Columns.Count).End(xlToLeft).Column) * 2
For i = 1 + 2 To x Step 2
.Columns(i).EntireColumn.Insert
Startrow = 2
Lastrow = y
UserName = .Cells(1, i - 1)
Set FormulaRange = .Range(.Cells(Startrow, i), .Cells(Lastrow + 1, i))
FormulaRange.FormulaR1C1 = "=VLookup(R1C[-1],'" & ActivityRange.Parent.Name & "'!" & ActivityRange.Address(1, 1, xlR1C1) & ", 2, False)"
'If you do not want dynamic formulas and just want the value
'then comment out the above and use the below.
'FormulaRange.Value = Application.Vlookup(UserName,ActivityRange,2,False)
Next
End With
End Sub
The R1C1 is a relative nomenclature. When it fills the formulas into the columns it will return the cell relative to the one into which the formula will be filled.
For example, above I use R1C[-1]. This says get the first row of the column directly to the left. So if the formula was being entered into B2 it would return A$1.
The [] denotes the relative address. Without the [] eg R1C1 it would indicate an absolute address and would return $A$1. So R1C1:R4C2 would return a range of $A$1:$B$4.