VBA to highlight duplicate rows in two Worksheets - excel

I know very little about VBA code, but I can follow along the lines of logic in a given example. So I googled and found a code I edited to highlight duplicates in a worksheet. However, I have a workbook with three sheets. I would like to adapt this to compare sheet 1 and sheet 3, then highlight the duplicates in sheet 1.
Sub Highlight_Dups()
Dim startRow As Integer
startRow = 2
Dim row As Integer
row = startRow
Do While (Range("A" & row).Value <> "")
Dim innerRow As Integer
innerRow = row + 1
Dim StudentID As String
Dim DT As String
Dim Description As String
StudentID = Range("A" & row).Value
DT = Range("H" & row).Value
Description = Range("J" & row).Value
Do While (Range("A" & innerRow).Value <> "")
If (Range("A" & innerRow).Value = StudentID And Range("H" & innerRow).Value = DT And Range("J" & innerRow).Value = Description) Then
Range("X" & row).Value = Range("X" & row).Value & innerRow & ", "
Range("X" & innerRow).Value = Range("X" & innerRow).Value & row & ", "
Rows(row).Interior.ColorIndex = 6
Rows(innerRow).Interior.ColorIndex = 6
End If
innerRow = innerRow + 1
Loop
row = row + 1
Loop
MsgBox "done", vbOKOnly, "done"
End Sub
Any help on how to add ???= Sheets("Sheet1") and ??? = Sheets("Sheet3")
would help me a great deal. Thanks

You might want to consider discarding the laborious task of looping through every cell while comparing it to every other and use a pair of conditional formatting rules.
Option Explicit
Private Sub cfrS1S3dupes()
With ThisWorkbook.Worksheets("sheet1")
With .Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "J"))
'get rid of pre-existing cfrs
.FormatConditions.Delete
'if duplicate in sheet1 found below row, then fill red
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=countifs($a$2:$a2, $a2, $h$2:$h2, $h2, $j$2:$j2, $j2)>1")
.Interior.Color = 255 'this is the color red
End With
'if duplicate anywhere in sheet3, then fill green
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=countifs(sheet3!$a:$a, $a2, sheet3!$h:$h, $h2, sheet3!$j:$j, $j2)")
.Interior.Color = 5287936 'this is the color green
End With
End With
End With
End Sub

First of all, you should declare 2 sheet objects to make it easier to read and future code maintences easier:
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'use this approach if your sheet's name is dinamic but never changes it's order
'Set ws1 = ThisWorkbook.Sheets(1)
'Set ws2 = ThisWorkbook.Sheets(2)
'use this if name is static
Set ws1 = ThisWorkbook.Sheets("name of worksheet1")
Set ws2 = ThisWorkbook.Sheets("name of worksheet2")
Then just put the Sheets objects in their specific locations like this (pay attention to the 'ws1's and 'ws2's):
Dim StudentID As String
Dim DT As String
Dim Description As String
Do While (ws1.Range("A" & Row).Value <> "")
innerRow = Row + 1
StudentID = ws1.Range("A" & Row).Value
DT = ws1.Range("H" & Row).Value
Description = ws1.Range("J" & Row).Value
Do While (ws2.Range("A" & innerRow).Value <> "")
If (ws2.Range("A" & innerRow).Value = StudentID And ws2.Range("H" & innerRow).Value = DT And ws2.Range("J" & innerRow).Value = Description) Then
'not sure what you are trying to do with this 3 lines, change it for your own needs
ws1.Range("X" & Row).Value = ws2.Range("X" & Row).Value & innerRow & ", "
ws1.Range("X" & innerRow).Value = ws2.Range("X" & innerRow).Value & Row & ", "
ws1.Rows(Row).Interior.ColorIndex = 6
ws1.Rows(innerRow).Interior.ColorIndex = 6
End If
innerRow = innerRow + 1
Loop
Row = Row + 1
Loop
End Sub
ps: i couldn't test it since you didn't provide the base of yours. But since you said you can read code and understand it's logic, I think you'll be fine :)

Related

Maintain complete cell range address when open several workbooks to loop through it

Hi I made a macro that creates different workbooks I'm trying to use it in a loop but the range changes to the open workbook and when I try to use the complete path to my workbook the variable in which I store the range marks "Nothing".
row = ActiveCell.row
Dim cell As Range
Dim quote As Integer
quotesToDo = Selection.Rows.Count
For quote = 1 To quotesToDo
cell = Workbooks("PLANTILLA FORECAST 2019.xlsm").Worksheets("CONTROL DE LEADS").Range("D" & row)
If cell.EntireRow.Hidden = False Then
row = cell.row
name = Range("D" & row).Value
location = Range("G" & row).Value
mail = Range("H" & row).Value
phone = Range("I" & row).Value
wantedProduct = Range("J" & row).Value
Call Query2(exchange, name, location, mail, phone, generalAddress, row)
End If
row = row + 1
Next quote
Please use set for Range object.

How to concatenate 2 columns and keep text styling with VBA?

I have several columns that I need to concatenante, while the text styling for one column is kept intact and each column is concatenated in a new line (carriage return).
Col A text in bold, Col B text normal, Col C = concatenated col A content in bold + carriage return + col B content.
Using Concatenate formula in combination with CHAR(10) works but obviously the text styling isn't kept. VBA seems to be the way to go but I'm a total newbie at it.
I found the following code that does the concatenation, kees the styling but for the life of me I cant figure how to include a carriage return with vbCrLf in a string.
Sub MergeFormatCell()
Dim xSRg As Range
Dim xDRg As Range
Dim xRgEachRow As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim I As Integer
Dim xRgLen As Integer
Dim xSRgRows As Integer
Dim xAddress As String
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xSRg = Application.InputBox("Select cell columns to concatenate:", "Concatenate in Excel", xAddress, , , , , 8)
If xSRg Is Nothing Then Exit Sub
xSRgRows = xSRg.Rows.Count
Set xDRg = Application.InputBox("Select cells to output the result:", "Concatenate in Excel", , , , , , 8)
If xDRg Is Nothing Then Exit Sub
Set xDRg = xDRg(1)
For I = 1 To xSRgRows
xRgLen = 1
With xDRg.Offset(I - 1)
.Value = vbNullString
.ClearFormats
Set xRgEachRow = xSRg(1).Offset(I - 1).Resize(1, xSRg.Columns.Count)
For Each xRgEach In xRgEachRow
.Value = .Value & Trim(xRgEach.Value) & " "
Next
For Each xRgEach In xRgEachRow
xRgVal = xRgEach.Value
With .Characters(xRgLen, Len(Trim(xRgVal))).Font
.Name = xRgEach.Font.Name
.FontStyle = xRgEach.Font.FontStyle
.Size = xRgEach.Font.Size
.Strikethrough = xRgEach.Font.Strikethrough
.Superscript = xRgEach.Font.Superscript
.Subscript = xRgEach.Font.Subscript
.OutlineFont = xRgEach.Font.OutlineFont
.Shadow = xRgEach.Font.Shadow
.Underline = xRgEach.Font.Underline
.ColorIndex = xRgEach.Font.ColorIndex
End With
xRgLen = xRgLen + Len(Trim(xRgVal)) + 1
Next
End With
Next I
End Sub
The interest of the above code is that it allows the user to specify via an input box the cells range to concatenate and where to output the results.
Anyone can give me a hand and modify it so each new column goes in a new line after concatenation?
If you got a simplier solution I'm all for it as long as it works.
p.s. I'm running Excel 2013 if that matters.
This below code does not copy formatting, but it is concatenate both columns and bold the value appears in column A.
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
With .Range("C" & Row)
.Value = ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value & vbNewLine & ThisWorkbook.Worksheets("Sheet1").Range("B" & Row).Value
.Characters(1, Len(ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
EDITED VERSION:
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
Dim strA As String, strB As String, strC As String, strD As String, strE As String, strF As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
strA = .Range("A" & Row).Value
strB = .Range("B" & Row).Value
strC = .Range("C" & Row).Value
strD = .Range("D" & Row).Value
strE = .Range("E" & Row).Value
strF = .Range("F" & Row).Value
With .Range("G" & Row)
.Value = strA & vbNewLine & strB & vbNewLine & strC & vbNewLine & strD & vbNewLine & strE & vbNewLine & strF
.Characters(1, Len(strA)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + 5), Len(strC)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + Len(strC) + Len(strD) + 9), Len(strE)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub

automatically updating vba concatenate column when changed

I'm concatenating 4 different formula based columns into one using VBA (to be able to change formatting while still concatenating). The concatenating VBA code works, but when the 4 individual columns update and pull the new information, the concatenated column doesn't change.
My concatenated code is this and it lies in column D or 4:
Sub joint1()
ActiveSheet.Range("a2", ActiveSheet.Range("a2").End(xlDown)).Select
Row = 2
Col = 4
For Each Cell In Selection
AE = Cells(Row, Col + 15)
Name = Cells(Row, Col + 9)
SC = Cells(Row, Col + 16)
PM = Cells(Row, Col + 10)
Cells(Row, Col) = Name & Chr(10) & "(" & AE & " - " & SC & ")" & Chr(10) & PM & " - PM"
With Cells(Row, Col)
.ClearFormats
.Characters(1, Len(Name)).Font.Bold = True
End With
Row = Row + 1
Next
End Sub
If you know how to add a feature to help my problem, I would be very appreciative!
Try this:
Option Explicit
Sub joint1()
Dim iRow As Long
Dim iCol As Long
Dim rng As Range
Dim rngSelect As Range
Dim Name As String
Set rngSelect = ActiveSheet.Range("a2", ActiveSheet.Range("a2").End(xlDown))
iRow = 2
iCol = 4
For Each rng In rngSelect
Name = Cells(iRow, iCol + 9)
Cells(iRow, Col) = "=M" & iRow & Chr(10) & " & ""("" & S" & iRow & " & "" - "" & T" & iRow & " & "")"" &" & Chr(10) & "N" & iRow & " & ""-PM"""
With Cells(iRow, iCol)
.ClearFormats
.Characters(1, Len(Name)).Font.Bold = True
End With
iRow = iRow + 1
Next
End Sub
This code creates a formula in each cell, rather than just copying the values.
The job could probably be done just as well with an excel formula. The formatting doesn't work with my version of excel (2007).

Assign value without formatting

I'm looping through workbooks to aggregate the data to one sheet. The data on the various source sheets is always in the same columns but the rows will vary.
I'm assigning values but conditional formatting is coming through.
Screen updating is off.
How can I copy values from one book to another?
For Each sheet In Workbooks(filename).Worksheets
If sheet.Name = "Template" Then
lastrow = sheet.Range("A" & Rows.Count).End(xlUp).row
For row = 2 To lastrow
All.Range("A" & All_nextrow).Value = sheet.Range("A" & row).Value
All.Range("B" & All_nextrow).Value = sheet.Range("B" & row).Value
All.Range("C" & All_nextrow).Value = sheet.Range("C" & row).Value
All.Range("D" & All_nextrow).Value = sheet.Range("D" & row).Value
All.Range("E" & All_nextrow).Value = sheet.Range("E" & row).Value
All.Range("F" & All_nextrow).Value = sheet.Range("F" & row).Value
All.Range("G" & All_nextrow).Value = sheet.Range("G" & row).Value
All.Range("H" & All_nextrow).Value = sheet.Range("H" & row).Value
All.Range("I" & All_nextrow).Value = sheet.Range("I" & row).Value
All.Range("J" & All_nextrow).Value = sheet.Range("J" & row).Value
All.Range("K" & All_nextrow).Value = sheet.Range("K" & row).Value
All.Range("L" & All_nextrow).Value = Workbooks(filename).Name
All_nextrow = All_nextrow + 1
Next row
End If
Next sheet
This might be what you are looking for. There are some issues with your code you need to know.
In this example, I'm using "All" as the name of the sheet you are putting this onto.
This code uses a simple loop to go through the columns, where you were using Range and the actual letter name of the column, this uses Cells(lRow, lCol) and loops that way, until you get to column L where you change the pattern.
I also removed the for each worksheet, because you are running an IF statement making ONLY "TEMPLATE" the one that will be used. So there is no need to loop through all of them to find the one you know you want. If you meant to use more than that, the If Sheet.Name = "Template" needs to go.
Give this code a shot, and modify it to your needs. I will be happy to modify the answer if you comment with any glitches.
Sub DataAggregate()
Dim sheet As String
Dim all As String
Dim allRow As Long
all = "All" 'whatever the name of "ALL" is, set here.
allRow = 2
sheet = "Template"
lastRow = Sheets(sheet).Range("A" & Rows.Count).End(xlUp).row
For lRow = 2 To lastRow
For lCol = 1 To 11
Sheets(all).Cells(allRow,lCol) = Sheets(sheet).Cells(lRow, lCol).Text
Next lCol
Sheets(all).Cells(allRow, "L") = sheet 'or filename' 'confused as to what you want
allRow = allRow + 1
Next lRow
Next ws
End Sub
I'm not sure of understanding what you need but if you want to copy all the cells between A2 and L{lastrow} you can use:
lastrow = SheetFrom.Range("A" & Rows.Count).End(xlUp).Row
SheetFrom.Range("A2:L" & lastrow).Copy
SheetTo.Range("A2").PasteSpecial (xlPasteValues)
Sub CopyPaste()
Dim WorkbookToCopy As Workbook
Dim WorkbookToPaste As Workbook
Dim RowCount As Integer
Set WorkbookToCopy = Workbook1 'Workbook to copy name like Workbook1
Set WorkbookToPaste = Workbook2
RowCount = 1 ' 'clean' row in WorkbookToPaste
For Each Sheet In Workbook1
For Each Column In Sheet
RowCount = 1
For Each Cell In Column
WorkbookToPaste.Sheets(Sheet).Cells(RowCount, Column).Value = Cell.Value
RowCount = RowCount + 1
Next
Next
Next
End Sub
I'm not sure that its work, but I would like to show you some logic, which you can use in your macro.
For anybody still looking for a good answer, the cells format can be controlled with use of 'NumberFormat' in conjunction with .FormulaR1C1.
When any value stored in a cell with ".value" it internally formatted. To override this you need to alter the NumberFormat and use '.FormulaR1C1' instead of '.value'.
All.Range("A" & All_nextrow & ":" & "L" & All_nextrow).NumberFormat = "#"
Then
All.Range("A" & All_nextrow).FormulaR1C1 = sheet.Range("A" & row).Value
You can achieve this by .copy and .PasteSpecial as suggested by #genespos but I'm not a fan of cell interactions during a macro execution.

How to format data into a row which in column

I have an excel sheet which need do format the data
I need to format this data like this in different sheet
Note - This a small sample I created for your understanding
my test macro is below. If you want to use it, you just need to rename your sheets - "DataSheet" for the one with the data and "ResultSheet" where the result will be stored.
Sub Reformat()
Dim letter As String
Dim iRow As Integer
Dim rng As Excel.Range
Sheets("ResultSheet").Range("A1:A" & Range("A1").End(xlDown).Row).Value = Range("A1:A" & Range("A1").End(xlDown).Row).Value
Sheets("ResultSheet").Select
Range("A1:A" & Range("A1").End(xlDown).Row).RemoveDuplicates Columns:=1, Header:=xlNo
Set rng = Range("A1:A" & Range("A1").End(xlDown).Row)
For i = 1 To Sheets("DataSheet").Range("A1").End(xlDown).Row
letter = Sheets("DataSheet").Range("A" & i).Value
iRow = WorksheetFunction.Match(letter, rng)
If Range("B" & iRow).Value = "" Then
Range("B" & iRow).Value = Sheets("DataSheet").Range("B" & i).Value
Else
Range("A" & iRow).End(xlToRight).Offset(0, 1).Value = Sheets("DataSheet").Range("B" & i).Value
End If
Next i
End Sub

Resources