Comparing Two Columns in Excel Row By Row? - excel

have currently browsed the forums and have came up with a code to compare two columns from two separate excel books and then highlight anything matching with the CompareRange. Here is a few more details about the problem:
I have two excel sheets. And data like this in each sheet:
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•6 .6 8 .45
•5 .5 9 .55
•4 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
As you can see, given this example nothing should be highlighted once the macro is run since nothing from Column A or B from the first sheet matches directly with Column N & O from the second sheet. The problem is that with the macro (module) I have come up with will highlight "3" from Column A and ".2" from Column B, just because they appear in Column N & Column O respectivally.
What I want: I only want a number to be highlighted if both the numbers "7" & ".7" are matched in the same row of Column N & Column O on the other spreadsheet. I have no idea how to do this. To be a little more precise, I'll give an example. Say I edited the data to be like this.
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•8 .45 8 .45
•5 .5 9 .55
•11 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
With this data, I would want the second row of A & B ("8" & ".45") highlighted, while my error "3" of Column A and ".2" of Column B is not highlighted. Also, I would like it if row 4 of Column A & B ("11" & ".4") is not highlighted at all either, just because in O it is .2 and in B it would be .4 even though the 11's match.
Please advise. Thanks in advance.
Attached is the macro/module I have entered in which is working kind of correctly but producing the mistake.
And also, (kind of a lesser problem), both the files with data will have the same header, example would be if Column A & Column N both had "Dogs" as it's title in Row 1 and Column B & O both had "Cats" as it's title in Row 1. Is there anyway the macro can be adjusted so it compares those two columns between the two workbooks without me even having to select or assigning a range? Thank you so much.
Sub Find_Matches()
Dim Column1 As Range
Dim Column2 As Range
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
If Column1.Columns.Count > 1 Then
Do Until Column1.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
Loop
End If
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
If Column2.Columns.Count > 1 Then
Do Until Column2.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column2.Rows.Count <> Column1.Rows.Count Then
Do Until Column2.Rows.Count = Column1.Rows.Count
MsgBox "The second column must be the same size as the first"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column1.Rows.Count = 65536 Then
Set Column1 = Range(Column1.Cells(1), Column1.Cells(ActiveSheet.UsedRange.Rows.Count))
Set Column2 = Range(Column2.Cells(1), Column2.Cells(ActiveSheet.UsedRange.Rows.Count))
End If
Dim CompareRange As Variant, x As Variant, y As Variant
' Set CompareRange equal to the range to which you will
' compare the selection.
Set CompareRange = Workbooks("Book4").Worksheets("Sheet1").Range("N2:N7")
Set CompareRange1 = Workbooks("Book4").Worksheets("Sheet1").Range("O2:O7")
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' each cell in CompareRange.
For Each x In Column1
For Each y In CompareRange
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
For Each x In Column2
For Each y In CompareRange1
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
End Sub

Replace both of your loops with one that compares both pairs of cells at the same time:
For i = 1 To Column1.Rows.Count
For j = 1 To compareRange.Rows.Count
If Column1.Cells(i, 1) = compareRange.Cells(j, 1) Then
If Column2.Cells(i, 1) = compareRange1.Cells(j, 1) Then
Column1.Cells(i, 1).Interior.Color = vbYellow
Column2.Cells(i, 1).Interior.Color = vbYellow
End If
End If
Next j
Next i

Related

Excel: transfer color filling from one document to another

I have two documents having some same rows (and some rows are different). In Document1 I work with file and color some rows (or cells).
How could I switch to Documnent2 and color the rows (cells) I colored in Document1 in the same way? Is there any parser available?
For example:
Doc1:
1 a 1 2 3 4 # is full colored
2 b 1 3 6 7
3 c 1 1 1 2 # is full colored
Doc2:
1 c 1 1 1 2
2 a 1 2 3 4
3 d 5 6 8 1
4 b 1 3 6 7
I need to color rows with indexes 1 and 2, because they are the same as in Doc1, and are full colored.
If I use Format Painter, I get first and third rows colored, but it's wrong for me.
I see the solution like formula, that checks by row letter, is it colored, or not, and colors the row letter in other document. But I don't know how to code it :(
P.S. I also have troubles with getting cell colours - GET.CELL(63,INDIRECT("rc",FALSE)) doesn't work for me, there is no GET.CELL() function found.
P.P.S. Both documents are too big (more than 1.000.000 rows), so I think the best solution would be formula (macroses often are too slow).
The speed of the code depends on how many cells are coloured
You'd have to adapt it to fit your needs
Option Explicit
' Credits: https://stackoverflow.com/a/30067221/1521579
' Credits: https://www.mrexcel.com/board/threads/vba-to-compare-rows-in-two-different-sheets-and-if-they-match-highlight-in-red.1067232/
Sub CheckRows()
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
Dim targetFile As Workbook
Set targetFile = ThisWorkbook 'Workbooks("File2")
Dim targetSheet
Set targetSheet = targetFile.Worksheets("Sheet2")
Dim sourceLastRow As Long
sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
Dim sourceRange As Range
Set sourceRange = sourceSheet.Range("A1:E" & sourceLastRow)
Dim targetLastRow As Long
targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
Dim targetRange As Range
Set targetRange = targetSheet.Range("A1:E" & targetLastRow)
Dim tempDict As Object
Set tempDict = CreateObject("scripting.dictionary")
Dim cellsString As String
' Add first range to dict
Dim sourceCell As Range
Dim sourceCounter As Long
For Each sourceCell In sourceRange.Columns(1).Cells
sourceCounter = sourceCounter + 1
' Check if cell has color
If sourceCell.Interior.Color <> 16777215 Then
cellsString = Join(Application.Index(sourceCell.Resize(, sourceRange.Columns.Count).Value, 1, 0), "|")
tempDict.item(cellsString) = sourceCell.Interior.Color
End If
Next sourceCell
' Check in target range
Dim targetCell As Range
Dim sourceColor As String
For Each targetCell In targetRange.Columns(1).Cells
cellsString = Join(Application.Index(targetCell.Resize(, targetRange.Columns.Count).Value, 1, 0), "|")
If tempDict.exists(cellsString) Then
sourceColor = tempDict.item(cellsString)
targetCell.Resize(, targetRange.Columns.Count).Interior.Color = sourceColor
End If
Next targetCell
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print SecondsElapsed, "Source rows:" & sourceLastRow, "Target rows: " & targetLastRow
End Sub
' Credits: https://stackoverflow.com/a/9029155/1521579
Function GetKey(Dic As Object, strItem As String) As String
Dim key As Variant
For Each key In Dic.Keys
If Dic.item(key) = strItem Then
GetKey = CStr(key)
Exit Function
End If
Next
End Function
If you're comfortable with adding few helper columns in both of your documents, you can use the following solution.
Note that the below solution demonstrates the data being in 2 sheets
within the same document. You can easily apply the same logic with
different documents.
Assumptions:
Number of columns remain the same in both documents
you're looking for an exact match
Solution:
You can download the sample excel document with the below solution from the following link.
Create a helper column(G) in both the documents which is a concatenation of all the existing columns using =TEXTJOIN(", ",FALSE,B2:E2) like below:
A B C D E F -----G-------
1 a 1 2 3 4 a, 1, 2, 3, 4
2 b 1 3 6 7 b, 1, 3, 6, 7
3 c 1 1 1 2 c, 1, 1, 1, 2
In document2 create another column(H) which will identify the corresponding row number from document1 using =IFERROR(MATCH(G2,'document 1'!$G$1:$G$5,0),0) formula. Like below
Note: 0 if no match is found
Add a formula in any cell which will calculate the total number of rows that should be checked in document2
A B C D E F -------G----- H
1 c 1 1 1 2 c, 1, 1, 1, 2 3
2 a 1 2 3 4 a, 1, 2, 3, 4 1
3 d 5 6 8 1 d, 5, 6, 8, 1 0
4 b 1 3 6 7 b, 1, 3, 6, 7 2
5
6 =COUNTA(G1:G4)
Once these columns are added, you can use these columns to loop through the rows in document2 and see if there is match in document1 and copy formatting if there is a match using the code below:
Public Sub Copy_Formatting()
'Stack Overflow question: https://stackoverflow.com/questions/65194893/excel-transfer-color-filling-from-one-document-to-another
Dim Curr_Range As Range, Match_Value As Integer, Rows_to_loop As Integer
Rows_to_loop = Sheet2.Range("G6").Value
For i = 1 To Rows_to_loop
Set Curr_Range = Sheet2.Range("B1:E1").Offset(i, 0)
Match_Value = Sheet2.Range("H1").Offset(i).Value
If Match_Value > 0 Then
Sheet1.Range("B1:E1").Offset(Match_Value - 1).Copy
With Curr_Range.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Curr_Range.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next i
End Sub
Checkout the following GIF that shows the result:
two options:
Use the format painter (mark the cells for which you want to copy formatting, click the format painter icon, switch to Document 2, select the cells where you want to paste formatting)
Use "paste formatting" using Ctrl-C -> go to Document 2 -> Paste Special -> Formats.
If I understand your question correctly: you want to copy only the formatting from excel file 2 to excel file 1 while retaining the information.
copy everything from file 2.
paste it in file 1 and press ctrl. Pick the bottom-left option to only retain formatting.
If you're using conditional formatting you can also just make a backup of file 2 and paste file 1 into file 2 while only retaining text (one of the ctrl paste options).

Selecting only 10 characters (right) on vba excel

I am trying to create a macro VBA that allow me for example:
Column A: 123456789101112 Column F : 6789101112
Only 10 characters in column F. If we have less than 10 characters in column A to complete with 0 for example:
Column A: 123458 Column F: 0000123458
This is the function that allow me to select the number of characters:
For i = 1 To table1Rows - 1
table1(1 + i, 6) = Right(table1(1 + i, 1), 15)
But I need to complete the 10 characters if I have less than 10 in column A.
This will place the formula in column F based on the amount of data in column A.
The formula uses r1c1 notation - R on its own means this row, C1 means column 1.
It's the same as writing =TEXT(RIGHT(A1,10),REPT(0,10)) and dragging down.
Sub Test()
Dim rLastRow As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rLastRow = .Cells(.Rows.Count, 1).End(xlUp) 'Based on column A (column #1)
'Column A Offset by 5 columns is column F.
.Range(.Cells(1, 6), rLastRow.Offset(, 5)).FormulaR1C1 = _
"=TEXT(RIGHT(RC1,10),REPT(0,10))"
End With
End Sub
I think this is what you're after:
For i = 1 To table1Rows - 1
table1(1 + i, 6) = Format(Right(table1(1 + i, 1), 10), "0000000000")
Next
following code will add the remaing zero's to your string:
Dim strnbr As String
strnbr = 123
While Len(strnbr) < 10
strnbr = "0" + strnbr
Wend

Copying data based on the headers from Sheet1 to Sheet2

I have a huge Excel sheet with about 2000 rows.
So Row 1 is the first header, the columns are: Unique Name, Length, Elevation. Then there is a bunch of data related to these columns.
Row 8 is another header, the columns are: Unique Name, Elevation, Element type. Again some data follows these columns.
And so on goes the Excel sheet with many such rows which are headers.
These headers are not in same order. Here is an example of Excel Sheet1:
Unique Name Length (ft) Elevation (ft) this is Row 1 (header1)
A 20 4 this is Row 2
B 5 10 this is Row 3
C 10 3
D 11 40
E 3 60
Row 7 is blank
Unique Name Elevation (ft) Element Type this is Row 8 (header2)
1 20 Pipe
2 5 Pipe
3 10 Pipe
Row 12 is blank
Unique Name Element Type Elevation Status this is Row 13 (header 3)
A1 VALVE 10 Open
A2 VALVE 2 Open
A3 VALVE 100 Open
. . . .
. . . .
. . . .
. . . .
I need to copy every single columns data from Sheet1 based on specific headers and paste it to Sheet2.
Here is an example of Sheet2, this is what I need:
Unique Name Length (ft) Elevation (ft) Status Element Type this is the only header I need
A 20 4
B 5 10
C 10 3
D 11 40
E 3 60
1 20 Pipe
2 5 Pipe
3 10 Pipe
A1 10 Open VALVE
A2 2 Open VALVE
A3 100 Open VALVE
. . . . .
. . . . .
. . . . .
. . . . .
I have searched a lot, and Alex's VBA code below is the closest I found in this help forum. But it obviously works only for data belonging to Row 1 Header.
Sub CopyPasteData()
Dim header As Range, headers As Range
Set headers = Worksheets("Sheet1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("Sheet2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)),
Application.Match(header, headers, 0), 0)
End Function
Thank you.
Should be easy enough to do if you can key off of the "Unique Name" in the first column as an indicator that a new header has been reached. You basically just need to keep track of 3 different mappings - columns for headings that have already been located, rows for unique names that have already been located, and the positions of the headers in the current section.
Dictionaries from the Microsoft Scripting Runtime work well for this. Something like this should do the trick:
Private Sub MergeSections()
Dim source As Worksheet, target As Worksheet
Dim found As Dictionary, current As Dictionary, uniques As Dictionary
Set source = ActiveSheet
Set target = ActiveWorkbook.Worksheets("Sheet2")
Set found = New Dictionary
Set uniques = New Dictionary
Dim row As Long, col As Long, targetRow As Long, targetCol As Long
targetRow = 2
targetCol = 2
Dim activeVal As Variant
For row = 1 To source.UsedRange.Rows.Count
'Is the row a header row?
If source.Cells(row, 1).Value2 = "Unique Name" Then
'Reset the current column mapping.
Set current = New Dictionary
For col = 2 To source.UsedRange.Columns.Count
activeVal = source.Cells(row, col).Value2
If activeVal <> vbNullString Then
current.Add col, activeVal
'Do you already have a column mapped for it?
If Not found.Exists(activeVal) Then
found.Add activeVal, targetCol
targetCol = targetCol + 1
End If
End If
Next col
Else
activeVal = source.Cells(row, 1).Value2
'New unique name?
If Not uniques.Exists(activeVal) Then
'Assign a row in the target sheet.
uniques.Add activeVal, targetRow
target.Cells(targetRow, 1).Value2 = activeVal
targetRow = targetRow + 1
End If
For col = 2 To source.UsedRange.Columns.Count
'Copy values.
activeVal = source.Cells(row, col).Value2
If source.Cells(row, col).Value2 <> vbNullString Then
target.Cells(uniques(source.Cells(row, 1).Value2), _
found(current(col))).Value2 = activeVal
End If
Next col
End If
Next row
'Write headers to the target sheet.
target.Cells(1, 1).Value2 = "Unique Name"
For Each activeVal In found.Keys
target.Cells(1, found(activeVal)).Value2 = activeVal
Next activeVal
End Sub

Find all instances of value in worksheet and sum the offset values

I have wbk1.worksheet(1) and wbk2.worksheet(1).
wbk1.worksheet(1) has a list of values in column A
wbk2.worksheet(2) has the same list of values that may occur multiple times in column A with a number value in the offset(0,1) cell.
I need to do an index or match to find all of values in wbk2 and sum all of the offset(0,1) values. Then take that sum and put it in the offset(0,1) cell in wbk1.worksheets(1).
Example:
Workbook 1, sheet 1
Column A Column B
value 1
value 2
value 3
Workbook 2, sheet 1
Column A Column B
value 1 15
value 2 2
value 1 3
value 1 12
End Result:
Workbook 1, sheet 1
Column A Column B
value 1 30
value 2 2
value 3 0
I've tried doing a for each loop, but I'm still a noob to vb, so clearly not doing something right:
For Each x In rngWbk1
Set cellrngwbk2 = wbk2.Worksheets(1).Cells.Find(What:=x, LookIn:=xlValues)
If Not cellrngwbk2 Is Nothing Then
For Each y In rngwbk1
If y = cellrngwbk2 Then
total = total + cellrngwbk2.Offset(0, 1).Value
Else
End If
Next y
x.Offset(0, 1).Value = total
total = 0 'resets total value for next x value
Else
End If
next x
If VBA is not a requirement, a simple =SUMIF() statement has the same effect.
The function would look something like this:
=SUMIF([Wbk2.xlsx]Sheet1!A2:A5,Table1[[#This Row],[ID]],[Wbk2.xlsx]Sheet1!B2:B5)
There is more efficient way. You can use SUMIF formula to calculate values and then rewrite formula with result values. If rngWbk1 corresponds to the values in column A in wbk1.worksheets(1), you can use following code:
Dim frm As String
Dim startCell As String
startCell = Replace(rngWbk1.Cells(1, 1).Offset(0, -1).Address, "$", "")
frm = "=SUMIF('[" & wbk2.Name & "]" & wbk2.Worksheets(1).Name & "'!A:A," & startCell & ", '[" & wbk2.Name & "]" & wbk2.Worksheets(1).Name & "'!B:B)"
With rngWbk1.Offset(0, 1)
.Formula = frm
.Calculate
.Value = .Value
End With
If rngWbk1 doesn't correspond values in column A, you need to adjust startCell in example to startCell = "A2" and change With rngWbk1.Offset(0, 1) to sth like With wbk1.Worksheets(1).Range("B1:B100")

Check if any rows are duplicate and highlight

I have data in (Sheet4) columns A to I:
I'm trying to compare data for all rows (Only on column A and B) to see if any of the rows is duplicated, if it is: excel should highlight both rows.
Example:
A B C......I
s 1 x
s 3 w
e 5 q
s 1 o
Row 1 and 4 should be highlighted as values are the same for column A and B.
I shouldn't modify the sheet (no modification to the columns or rows should be done to the sheet), and the number of rows is not always known (not the same for all files).
Is there an easy way (using macros) to do this???
This is an attempt I have tried, but it is increasing my file to 7MB!!!!! I'm sure there should be an easier way to compare rows for an unknown number of rows and just highlight the dupllicates if they exist:
Public Sub duplicate()
Dim errorsCount As Integer
Dim lastrow As Integer
Dim lastrow10 As Integer
errorsCount = 0
lastrow = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row 'is the row number of the last non-blank cell in the specified column
lastrow10 = lastrow
Sheet10.Range("B1:B" & lastrow10).Value = Sheet4.Range("A1:A" & lastrow).Value
Set compareRange = Sheet10.Range(column + "2:" & Sheet10.Range(column + "2").End(xlDown).Address)
For Each a In Sheet10.Range(column + "2:" & Sheet10.Range(column + "2").End(xlDown).Address)
c = a.Value
If c <> Null Or c <> "" Then
If name = "testing" Then
If WorksheetFunction.CountIf(compareRange, c) > 1 Then
a.Interior.ColorIndex = 3
errorsCount = errorsCount + 1
End If
End If
End If
Next a
If errorsCount > 0 Then
MsgBox "Found " + CStr(errorsCount) + " errors"
Else
MsgBox " No errors found."
End If
End Sub
Silly answer to you.
J1 or just duplicate sheet.
J1 =CONCATENATE(A1,"#",B1) > drag down > J:J > conditional format > highlight cells rules > duplicate values.
(* replace the # to any string which you think not possible in the original A:A and B:B.)
I do this all the time.
To collect all duplicates just SORT with color.

Resources