I am creating a macro that will compare the sheets of two workbook. And I need the row to be highlighted if found duplicate in a sheet of another workbook. So far, I have been search and I found code but I am not sure how I can highlight the cell / entire row if it found a duplicate in another sheet of another workbook. Here is my code below:
Sub CompareWorkbooks()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "B2:D49"
Set wbkA = ActiveWorkbook
Set varSheetA = wbkA.Worksheets("SAP").Range(strRangeToCheck)
Set wbkB = Workbooks.Open(FileName:="C:\Request Distribution\Reminder 20170302.xls")
Set varSheetB = wbkB.Worksheets("SAP").Range(strRangeToCheck)
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
'What to put to hightlight the cell / entire row
Else
'Some msgbox to display that there are no duplicates between sheets of 2 workbooks
End If
Next
Next
End Sub
Sub CompareWorkbooks()
Dim varSheetA As Range
Dim varSheetB As Range
Dim r As Range
Dim wbkA As Workbook
Dim rFind As Range
Set wbkA = ActiveWorkbook
With wbkA.Worksheets("SAP")
.UsedRange.Interior.ColorIndex = xlNone
Set varSheetA = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With
Set wbkB = Workbooks.Open(Filename:="C:\Request Distribution\Reminder 20170302.xls")
Set varSheetB = wbkB.Worksheets("SAP").Range(varSheetA.Address)
For Each r In varSheetA
Set rFind = varSheetB.Find(What:=r, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
r.Interior.Color = RGB(127, 187, 199)
End If
Next r
End Sub
Related
I am new to VBA and trying to select few column based on header of 2 file and compare them. To achieve this I am copying the column based on header such xx,yy,zz from 2 sheet to new sheet leaving few column as blank to separate 2 sheet data and compare the column. Diff will be highlighted in red.
Tried below code to copy data but I am getting subscription out of range for target file(highlighted below).
Sub CopyByHeader()
Dim CurrentWS As Worksheet
Set CurrentWS = ActiveSheet
Dim SourceWS As Worksheet
Set SourceWS = Workbooks("ALL_01.00.xls").Worksheets(1)
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range
Dim fl As Object
Set fl = CreateObject("scripting.filesystemobject").GetFile("Result.xlsx")
If fl Is Nothing Then
Workbooks.Add.SaveAs Filename:="Result"
End If
Dim TargetWS As Worksheet
**Set TargetWS = Workbooks("Result.xlsx").Worksheet(2)**
Dim TargetHeader As Range
Set TargetHeader = TargetWS.Range("A1:AX1")
Dim RealLastRow As Long
Dim SourceCol As Integer
Dim Header() As Variant
Dim k As Integer
HeaderList = Array("xx", "yy", "zz")
SourceWS.Activate
For Each Cell In TargetHeader
If Cell.Value <> "" Then
Set SourceCell = Rows(SourceHeaderRow).Find _
(Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
SourceCol = SourceCell.Column
RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If RealLastRow > SourceHeaderRow Then
Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
SourceCol)).Copy
TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
End If
End If
End If
Next
CurrentWS.Activate
End Sub
Anyone have a macro to paste to multiple ranges in the same sheet?
Trying to get values into every other column'
Sub CopySelections()
Set cellranges = Application.Selection
Set ThisRng = Application.InputBox("Select a destination cell", "Where to paste slections?", Type:=8)
For Each cellrange In cellranges.Areas
cellrange.Copy ThisRng.Offset(i)
i = i + cellrange.Rows.CountLarge
Next cellrange
End Sub
Maybe this?
Sub Add_Spaces()
Dim ICount As Integer
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
Set Sheet1 = wb.Worksheets("Sheet1")
Set Sheet2 = wb.Worksheets("Sheet2")
Dim IStart As Integer
Dim copyz As Integer
Dim destinationz As Integer
ICount = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
IStart = 1
destinationz = 1
For copyz = 1 To ICount Step IStart
Sheet1.Select
Columns(copyz).Select
Selection.Copy
Sheet2.Select
Columns(destinationz).Select
Sheet2.Paste
destinationz = destinationz + 2
Next copyz
End Sub
Before:
After:
I want to compare all cells of sheet 1 to sheet 2 and matched values turn yellow, following code i used,
Sub match()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "A1:IV65536"
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck)
Debug.Print Now
For icell = LBound(varSheetA, 1) To UBound(varSheetA, 1)
If varSheetA(icell) = varSheetB(icell) Then
cell.Interior.Color = vbYellow
`enter code here` End If
Next icell
End Sub
Try
Sub match()
Dim shtA As Worksheet
Dim shtB As Worksheet
Dim strRangeToCheck As String
Dim cA as range, cB as range
strRangeToCheck = "A1:IV65536"
set shtA = Worksheets("Sheet1")
set shtB = Worksheets("Sheet2")
Debug.Print Now
For Each cA IN shtA.Range(strRangeToCheck)
on error resume next
if cA.value <> "" then
Set cB = shtB.Range(strRangeToCheck).find(what:=cA.value, lookin:=xlvalues, lookat:=xlwhole)
If Not cB is Nothing then
cA.Interior.Color = vbYellow
End If
end if
on error goto 0
Next cA
End Sub
I have a code to copy the entire row if column B contains a certain text ("ACK-", but now I need to copy the entire row directly above the one with the certain text ("ACK-". Is this even possible? Any help will be appreciated.
Sub HEA_Filter()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
To reference "the row above", you can use the Range.Offset method:
rngCells.Offset(-1).EntireRow.Copy wsDest.Range("A" & DestNoRows)
' ^^^^^^^^^^^^
However, be aware that this raised a runtime error if the range is at row 1, because row 0 does not exist. You might want to add a check for it, for example:
If rngCells.Row > 1 Then rngCells.Offset(-1).EntireRow.Copy ...
Despite reading several threads searching for answers to similar problems I have been unable to debug my code on its own.
I am trying to write a macro that will search all cells between AE and BF for the term "Aeronautics Engineers" and then copy all rows that contain that term to a new sheet. The entire sheet has a total of 99289.
I have tried using the following code without any luck:
Sub MoveAero()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("Aeronautic")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
Thanks for any assistance!
Your problem is in your j loop:
For J = 0 To UBound(strArray)
The UpperBound (Ubound) of array strArray is 0. It's an array with a single element "Aeronautic".
So your loop is looping once and exiting.
Instead try looping through your range:
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
Found = True
Exit For
End if
Next rngCell
Here we loop through that rngCells range that you just made, cell by cell. Then we test if if the cell has the value you are looking for. If we find it, we set found to true and exit the for loop. You don't have to exit the for loop, but we found what we wanted, so there is no reason not to save some cpu time.
Full code, removed unnecessary variables and moved a little bit around:
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngCell as Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
'Moved this logic up from the IF block below
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
Exit For
End if
Next rngCell
Next I
End Sub
Alternatively, you could use that .find method of the range object instead of the second For loop. (Using both for your needs is unnecessary).
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim rngCells As Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
'Try to find your search term in the range
If Not (rngCells.Find("Aeronautic") Is Nothing) Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub