I am having trouble with getting the below VBA code to highlight the non-matches in column H on the sheets with the name "Revision". The master matching list is called "Materials" and it is column A there. Every time I run my current code, the whole column in the Revision sheet turns red. How do I get it to only highlight the non-match?
For example, say the "Materials" master sheet has the list Copper, and Steel. On the revision sheet it has Aluminum and Steel. How can the sheet only highlight the cell that says Aluminum in red?
Thanks.
Private Sub MaterialMatch()
Dim iRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws2 = Worksheets("Materials")
Dim FoundRow As Variant
Dim lRowSource As Long
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name Like "Revision *" Then
lRowSource = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row 'find last row in column A
For iRow = 2 To lRowSource
FoundRow = Application.Match(ws1.Cells(iRow, "H"), ws1.Columns("A"), 0)
If IsError(FoundRow) Then
ws1.Cells(iRow, "H").Interior.ColorIndex = 3
End If
Next iRow
End If
Next ws1
End Sub
Related
I have been running into some issues trying to use VBA to compare 2 tables in different worksheets, and then copy any rows in the "Master" sheet that are not found in the "New" sheet. Both tables are formatted as tables. The match is based on an "ID" column in Column A of both tables. If an ID is in the "Master" sheet, but not in the "New" sheet, than that entire row should be copy and pasted to the end of the table in the "New" sheet.
I updated some code found in another forum, which is almost working. However, it only seems to paste over the ID data into Column A, and not the entire corresponding row of data which is needed.
Sub compare()
Dim i As Long
Dim lrs As Long
Dim lrd As Long
With Worksheets("Master")
lrs = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lrs 'assumes header in row 1
If Application.IfError(Application.Match(.Cells(i, 1), Worksheets("New").Columns(1), 0), 0) = 0 Then
lrd = Worksheets("New").Cells(Worksheets("test").Rows.Count, 1).End(xlUp).Row
Worksheets("New").Cells(lrd + 1, 1).Value = .Cells(i, 1).Value
End If
Next i
End With
End Sub
I think the issue has to do with the "Cells" reference, instead of a range, but I do not know how to make that line dynamic.
Slightly different approach, but you need to use something like Resize() to capture the whole row, and not just the cell in Col A.
Sub compare()
Const NUM_COLS As Long = 10 'for example
Dim wb As Workbook, wsSrc As Worksheet, wsDest As Worksheet
Dim c As Range, cDest As Range
Set wb = ThisWorkbook 'or ActiveWorkbook for example
Set wsSrc = wb.Worksheets("Master")
Set wsDest = wb.Worksheets("New")
Set cDest = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'next empty row
For Each c In wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row).Cells
If IsError(Application.Match(c.Value, wsDest.Columns(1), 0)) Then
cDest.Resize(1, NUM_COLS).Value = c.Resize(1, NUM_COLS).Value
Set cDest = cDest.Offset(1) 'next row
End If
Next c
End Sub
(not in a range, not adjacent columns)
(in given order)
I have many rows on Sheet1. I would like to copy some columns of a row (not the entire row and not a range of columns) to Sheet2 (to the first empty row of Sheet2) if a cell satisfies a condition (the cell in the current row and A column has a value of y)
I would like to copy not the entire row from Sheet1 only the row with those columns that are given on Sheet3 (Column A), and the new column number (on Sheet2) is also given on Sheet3 (column B)
It would be simple if my task would be to copy the entire row, or the selected column would be in a range...but i would need to copy those columns that are specialized on Sheet3. I would be grateful for any help. Thanks in advance.
Sheet1 shows an example data sheet. The criteria is if Cells(Rows, 1).Value = "y"
Sheet2 shows the desired result.
Sheet3 shows the selected column number on Sheet1 and the new column number on Sheet2
Whilst this probably should be done using arrays more, here's some basic VBA code that loops the first sheet checking for "y" in the first column. When it finds it, it then loops the column mappings in the third sheet that have been saved into arrays to set the values on the second sheet:
Sub sTranasferData()
On Error GoTo E_Handle
Dim aOld() As Variant
Dim aNew() As Variant
Dim wsIn As Worksheet
Dim wsOut As Worksheet
Dim wsTrack As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim lngLoop2 As Long
Dim lngRow As Long
Dim lngTrack As Long
Set wsIn = Worksheets("Sheet1")
Set wsOut = Worksheets("Sheet2")
Set wsTrack = Worksheets("Sheet3")
lngLastRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
lngTrack = wsTrack.Cells(wsTrack.Rows.Count, "A").End(xlUp).Row
aOld() = wsTrack.Range("A2:A" & lngTrack).Value
aNew() = wsTrack.Range("B2:B" & lngTrack).Value
lngRow = 1
For lngLoop1 = 2 To lngLastRow
If wsIn.Cells(lngLoop1, 1) = "y" Then
For lngLoop2 = LBound(aOld) To UBound(aOld)
wsOut.Cells(lngRow, aNew(lngLoop2, 1)) = wsIn.Cells(lngLoop1, aOld(lngLoop2, 1))
Next lngLoop2
lngRow = lngRow + 1
End If
Next lngLoop1
sExit:
On Error Resume Next
Set wsIn = Nothing
Set wsOut = Nothing
Set wsTrack = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sTransferData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
I have Three worksheets, and essentially I want to select a cell in Column A of Sheet 2 (As the Active Cell) and check if there are any duplicates in Column A of Sheet 3 (The Range for this Sheet should be from A1 to the last row of Data).
If there are any duplicates, I would like a msgbox to display the number of duplicate values if it's greater than 3.
I have added comments explaining my logic in each step, please feel free to simplify my code as well:
Sub Check_Duplicates()
'Declaring variables
Dim Cell As Variant
Dim Source As Range
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rowAC As Long
Dim Counter As Long
'Assigning a worksheet to the decalred variables
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
'Sets the Long variable as the Active Cell Row in Sheet 2
rowAC = ActiveCell.Row
'Initializing "Source" variable range to last row in Sheet 3
Set Source = sh3.Range("A1", sh3.Range("A1").End(xlDown))
'Looping through each cell in the "Source" variable Range
For Each Cell In Source
'Checking if the "Cell" values in Sheet 3 (in column A to the last row) are equal to the value in the Active Cell in Column A
If Cell.Value = sh2.Range("A" & rowAC).Value Then
'Checking whether the value in "Cell" already exists in the "Source" range
If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
'Counts and stores the number of duplicate values from Sheet 3 "Cells" compared to the Active Cell value in Sheet 1 Column A
Counter = Application.WorksheetFunction.CountIf(sh3.Range("Source,Cell"), sh2.Range("A" & rowAC))
'If there are more than 3 duplicates then display a message box
If Counter > 3 Then
'Msgbox displaying the number of duplicate values in Sheet 3
MsgBox "No. of duplicates is:" & Counter
End If
End If
End If
Next
End Sub
Currently, my code gets to the first IF Statement and simply goes to the End IF, so it doesn't execute past this line and simply goes to Next and then End Sub:
If Cell.Value = sh2.Range("A" & rowAC) .Value Then
Cross Referencing:
https://www.mrexcel.com/board/threads/how-to-check-for-duplicates-and-display-a-count-msgbox.1125070/
Here is the final code I am using for anyone using this question as reference for their issues:
Sub Check_Duplicates()
'Declaring variables
Dim Source As Range
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rowAC As Long, Counter As Long
'Assigning a worksheet to the decalred variables
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
'Sets the Long variable as the Active Cell Row in Sheet 2
rowAC = ActiveCell.Row
'Initializing "Source" variable range to last row in Sheet 3
Set Source = sh3.Range("A1", sh3.Range("A" & Rows.Count).End(xlUp))
'count number of times is in Source range
Counter = Application.WorksheetFunction.CountIf(Source, sh2.Range("A" & rowAC))
'If there are more than 3 duplicates then display a message box
If Counter > 3 Then
'Msgbox displaying the number of duplicate values in Sheet 3
MsgBox "No. of duplicates is: " & Counter
End If
End Sub
The following code seems to run smoothly but nothing was copied onto the desired page
Sub a2()
Sheets.Add.Name = "25 degree"
Sheets("25 degree").Move after:=Sheets("data")
Dim x As Long
For x = 2 To 33281
If Cells(x, 1).Value = 25 Then
Cells("x,1:x,2:x,3:x,4:x,5:x,6").Copy
Worksheets("25 degree").Select
ActiveSheet.Paste
End If
Next x
End Sub
I highly recommend not to use .Select or ActiveSheet instead specify the sheet for each Cells() object according to How to avoid using Select in Excel VBA.
Option Explicit
Public Sub DoSomeCoypExample()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet
'better define by name
'Set wsSource = ThisWorkbook.Worksheets("source sheet")
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets("data")) 'add at the correct position and set it to a variable
wsDestination.Name = "25 degree" 'so you can use the variable to access the new added worksheet.
Dim iRow As Long
For iRow = 2 To 33281 'don't use fixed end numbers (see below if you meant to loop until the last used row)
If wsSource.Cells(iRow, 1).Value = 25 Then
With wsSource
.Range(.Cells(iRow, 1), .Cells(iRow, 6)).Copy Destination:=wsDestination.Range("A1")
'this line will copy columns 1 to 6 of the current row
'note you need to specify the range where you want to paste
'if this should be dynamic see below.
End With
End If
Next iRow
End Sub
If you want to loop until the last used row you can get that with something like
Dim LastRow As Long
LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row 'last used row in column A
If you want to paste into the next free row in your destination worksheet instead of a fixed range Destination:=wsDestination.Range("A1") you can use the same technique as above to finde the next free row:
Dim NextFreeRow As Long
NextFreeRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
So you can use that in your paste destination:
Destination:=wsDestination.Range("A" & NextFreeRow)
I am brand new to VBA coding and am confused on how I would be able to copy and paste values from one sheet to another if two criteria points are met. In the sheet below I want to copy "12, 9, and 15" and paste it into the "Expected, P10 and P90" cells on sheet2 if the names on sheet one "Orange, Green" match those on sheet 1.
I've been attempting this on my own for quite some time now with now luck.
Attached is the code I started
Sub Copy_Certain_Data()
a = Worksheets("Schedule Results").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If Worksheets("Schedule Results").Cells(i, 3).Value = "NE2P1" Then
Worksheets("schedule results").Rows(i).Copy
Worksheets("Campaign 1 Data").Activate
Range("F2").Select
ActiveSheet.Paste
Worksheets("Schedule Results").Activate
End If
Next
Application.CutCopyMode = False
End Sub
Below is a basic macro to loop through two worksheets and find the row that has matching values in columns A and B. Then writing the values from the row in sheet 1, columns C:E to the row in sheet 2, columns D:F.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim xCel As Range, yCel As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'change sheet names as needed
Set ws2 = ThisWorkbook.Sheets("Sheet2")
For Each xCel In ws1.Range("A2", ws1.Range("A" & ws1.Rows.Count).End(xlUp)) 'loop sheet1 column A
If xCel.Value = "Orange" And xCel.Offset(, 1).Value = "Green" Then 'when both values are found in row goto sheet2 loop
For Each yCel In ws2.Range("A2", ws2.Range("A" & ws2.Rows.Count).End(xlUp)) 'Loop sheet2 Column A
If yCel.Value = "Orange" And yCel.Offset(, 1).Value = "Green" Then 'when found write values from sheet1 to sheet2
yCel.Offset(, 3).Resize(, 3).Value = xCel.Offset(, 2).Resize(, 3).Value
End If
Next yCel
End If
Next xCel
This should give you a start to get you what you are trying to accomplished based on the code you have tried. Its always best practice to set your variables and also qualify worksheets.
Using .copy and .paste can cause issues because if the cells are not the same size you will get an error stating such and that is why I always set the destination cell value = the source cell value.
Option Explict
Sub Copy_Certain_Data()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Sheets("Schedule Results")
Set wsDest = wb.Sheets("Campaign 1 Data")
Dim LastRow As Long, i As Long
LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
If wsSource.Cells(i, 3).Value = "NE2P1" Then
wsDest.Cells(i, 6) = wsSource.Cells(i, 3)
End If
Next i
End Sub