I would like to highlight matching values in two different ranges and worksheets using VBA.
Worksheet #1 is named "OVR" with the range S2:V100 (where the highlighted values should show).
Worksheet #2 is named "LS" with the range A2:A101 containing a list of names.
My goal is to highlight all the cells in the range S2:V100 (from the "OVR" worksheet) that have a match with one of the cells in the range A2:A101 (from the "LS" worksheet).
I would like to integrate it to existing VBA for this file.
Sub FindReference()
LR1 = Worksheets("LS").Cells(Rows.Count, "A").End(xlUp).Row
LR2 = Worksheets("OVR").Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = Worksheets("LS").Range("A2:A101" & LR1)
Set rng2 = Worksheets("OVR").Range("S2:V100" & LR1)
For Each rCell In rng1
rCell.Interior.ColorIndex = xlNone
rCell.Validation.Delete
result = WorksheetFunction.CountIf(rng2, rCell)
If result > 0 Then rCell.Interior.Color = vbGreen
Next
End Sub
Color Matching Cells
Option Explicit
Sub FindReference()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim lRow As Long
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("LS")
lRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A2:A" & lRow)
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("OVR")
lRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
Dim drg As Range: Set drg = dws.Range("S2:V" & lRow)
' Combine matching cells.
Dim durg As Range
Dim dCell As Range
Dim dValue As Variant
For Each dCell In drg.Cells
dValue = dCell.Value
If Not IsError(dValue) Then
If Len(dValue) > 0 Then
If IsNumeric(Application.Match(dValue, srg, 0)) Then
If durg Is Nothing Then
Set durg = dCell
Else
Set durg = Union(durg, dCell)
End If
End If
End If
End If
Next dCell
' Color matching cells.
drg.Interior.ColorIndex = xlNone
drg.Validation.Delete
If Not durg Is Nothing Then
durg.Interior.Color = vbGreen
End If
' Inform.
MsgBox "Data highlighted.", vbInformation
End Sub
Related
wish you all the best.
I am making a code using VBA to find and detect errors from one sheet and paste the values from column A and B from the row of the error to the destination sheet.
my code is mostly working my issue is the content that is pasting which is the error cell and the next one to the right instead of the values from A and B (example: imagine macro is running all values in column K and there is an error in K85, it is pasting K85 and L85, instead of A85 and B85)
Sub Copy_NA_Values()
Dim rng As Range
Dim firstBlank As Range
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Set shtSource = ThisWorkbook.Sheets("JE Royalty detail") 'Change to the name of the source sheet
Set shtDestination = ThisWorkbook.Sheets("DB") 'Change to the name of the destination sheet
Set rng = shtSource.Range("F:F").SpecialCells(xlCellTypeFormulas, xlErrors)
For Each cell In rng
If IsError(Range("F:F")) = False Then
Set firstBlank = shtDestination.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
cell.Resize(1, 2).Copy firstBlank
End If
Next cell
End Sub
How can I make it so it will paste the correct cells i have tried to use paste special but I might've used it wrongly but I had errors, all help apreciated.
Have a good one.
it is pasting K85 and L85, instead of A85 and B85
Try replacing:
cell.Resize(1, 2).Copy firstBlank
with
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy firstBlank
To paste only values, do this instead:
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy
firstBlank.PasteSpecial (xlPasteValues)
Copy Values When Matching Error Values
Option Explicit
Sub BackupErrorValues()
Const SRC_NAME As String = "JE Royalty detail"
Const SRC_ERROR_RANGE As String = "F:F"
Const SRC_COPY_RANGE As String = "A:B"
Const DST_NAME As String = "DB"
Const DST_FIRST_CELL As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range
On Error Resume Next ' to prevent error if no error values
Set srg = Intersect(sws.UsedRange, sws.Columns(SRC_ERROR_RANGE)) _
.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If srg Is Nothing Then
MsgBox "No cells with error values found.", vbExclamation
Exit Sub
End If
Set srg = Intersect(srg.EntireRow, sws.Range(SRC_COPY_RANGE))
Dim cCount As Long: cCount = srg.Columns.Count
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
If dws.FilterMode Then dws.ShowAllData ' prevent failure of 'Find' method
Dim dCell As Range
With dws.UsedRange
Set dCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
End With
If dCell Is Nothing Then
Set dCell = dws.Range(DST_FIRST_CELL)
Else
Set dCell = dws.Cells(dCell.Row + 1, dws.Range(DST_FIRST_CELL).Column)
End If
Dim drrg As Range: Set drrg = dCell.Resize(, cCount)
Dim sarg As Range, srCount As Long
For Each sarg In srg.Areas
srCount = sarg.Rows.Count
drrg.Resize(srCount).Value = sarg.Value
Set drrg = drrg.Offset(srCount)
Next sarg
MsgBox "Error rows backed up.", vbInformation
End Sub
I have a file with a few sheets, I need to extract values from each not empty cell into a column on another sheet.
Would be awesome if while doing that duplicates can be removed as well.
The following code infinitely loops. I don't see how to break the loop since all the events are being used in the body of the code.
Range where the cells are being looked for on both sheets are different, that is why I used .End(xlUp) to define the last row with values in cells.
I cannot use empty cells as a trigger for stopping the loop because there are empty cells between cells with values.
Sub updt()
Dim ws As Worksheet, currWs As Worksheet, Lng As Integer, rng As Range
Set ws = wb.Worksheets("Sheet1") 'the source sheet
Set currWs = Sheets("Sheet2") 'the destination sheet
Lng = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A2:A" & Lng)
For Each c Lng rng
If WorksheetFunction.CountIf(currWs.Range("A:A"), c.Value) = 0 Then
currWs.Range("A" & currWs.Cells(Rows.Count, 1).End(xlUp).Row)(2) = c.Value
End If
Next
End Sub
Update Column With Unique Non-Existing Values From a Column of Another Worksheet Using a Dictionary
To avoid further complications, no arrays are used.
Option Explicit
Sub UpdateWorksheet()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet, calculate the last row
' and reference the source column range.
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A2:A" & slRow)
' Reference the destination worksheet and calculate the last row.
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
' Define a dictionary (object).
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive
' Declare variables.
Dim cCell As Range
Dim cKey As Variant
' Write the unique values from the destination column range
' to the dictionary.
If dlRow > 1 Then ' 1 means 'first row - 1' i.e. '2 - 1'
Dim drg As Range: Set drg = dws.Range("A2:A" & dlRow)
For Each cCell In drg.Cells
cKey = cCell.Value
If Not IsError(cKey) Then ' exclude error values
If Len(cKey) > 0 Then ' exclude blanks
dict(cKey) = Empty
End If
End If
Next cCell
End If
' Add the unique values from the source column range
' to the dictionary.
For Each cCell In srg.Cells
cKey = cCell.Value
If Not IsError(cKey) Then ' exclude error values
If Len(cKey) > 0 Then ' exclude blanks
dict(cKey) = Empty
End If
End If
Next cCell
' Check if the dictionary is empty.
If dict.Count = 0 Then
MsgBox "No valid values found.", vbCritical
Exit Sub
End If
' Clear the previous values from the destination first cell to the bottom
' of the worksheet.
Dim dCell As Range: Set dCell = dws.Range("A2")
With dCell
.Resize(dws.Rows.Count - .Row + 1).ClearContents
End With
' Write the unique values from the dictionary to the destination worksheet.
For Each cKey In dict.Keys
dCell.Value = cKey ' write
Set dCell = dCell.Offset(1) ' reference the cell below
Next cKey
' Inform.
MsgBox "Worksheet updated.", vbInformation
End Sub
You might want to use AdvancedFilter:
Option Explicit
Sub Copy_Advanced()
Dim ws As Worksheet, currWs As Worksheet, Lng As Integer, rng As Range
Set ws = Worksheets("Sheet1") 'the source sheet
Set currWs = Sheets("Sheet2") 'the destination sheet
Lng = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & Lng)
ws.Range("D1").Value = ws.Range("A1").Value
ws.Range("D2") = ">0"
ws.Range(rng.Address).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("D1:D2"), _
CopyToRange:=currWs.Range("A1"), _
Unique:=True
End Sub
I'm trying to copy and paste nonblank cells from sheet1 to sheet2.
I'm getting application/object error.
Public Sub CopyRows()
Sheets("Sheet1").Select
FinalRow = Cells(Rows.Count, 1).End(xlDown).Row
For x = 4 To FinalRow
ThisValue = Cells(x, 1).Value
NextRow = Cells(Rows.Count, 1).End(xlDown).Row
If Not IsEmpty(ThisValue) Then
Cells(x, 1).Resize(1, 6).Copy
Sheets(2).Select
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets(1).Select
End If
Next x
End Sub
Copy Rows
Option Explicit
Sub CopyRows()
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
If slRow < 4 Then Exit Sub ' no data
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
Application.ScreenUpdating = False
Dim sCell As Range
Dim sr As Long
' Loop and copy.
For sr = 4 To slRow
Set sCell = sws.Cells(sr, "A")
If Not IsEmpty(sCell) Then
Set dCell = dCell.Offset(1)
sCell.Resize(, 6).Copy dCell
End If
Next sr
Application.ScreenUpdating = True
' Inform.
MsgBox "Rows copied.", vbInformation
End Sub
There are multiple problems in your original code. As cybernetic.nomad already pointed out, avoid using Select whenever possible. You also set your NextRow variable to always be the last row in the worksheet instead of the next available row in your destination sheet. Additionally, because of your use of .Select, you have ambiguous Cells calls.
Here is an alternate method using AutoFilter because, for this task, you can take advantage of filtering to only get populated cells without having to perform a loop:
Sub CopyRows()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet1")
Dim wsDst As Worksheet: Set wsDst = wb.Worksheets("Sheet2")
Dim rData As Range: Set rData = wsSrc.Range("A3", wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp))
If rData.Rows.Count < 2 Then Exit Sub 'No data
With rData
.AutoFilter 1, "<>"
.Offset(1).Resize(, 6).Copy wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End Sub
By using manual selection(s) , I copy range(s) from workbook to another workbook.
But, how to select the headings of this selection(s) to be union with the selection itself , to fulfill copy and paste in one shot.
Headings are found on first row. e.g, contiguous selection if I selected Range “B3:D5” , subsequently I need to select ”B1:D1” and union with Range “B3:D5”.
e.g, non-contiguous selection if I selected Range “B3:D5,F3:F5” , subsequently I need to select ”B1:D1,F1” and union with Range “B3:D5,F3:F5”
Copying of contiguous selection and non- contiguous selections (in the same rows) works without problem.
In advance, grateful for useful answer and comments.
Dim wb As Workbook: Set wb = ThisWorkbook 'Source Workbook
Dim srg As Range: Set srg = wb.ActiveSheet.Range(Selection.Address)
Dim wb1 As Workbook: Set wb1 = Workbooks.Add 'Destination Workbook
Dim drg As Range: Set drg = wb1.Sheets(1).Range("A1")
srg.Copy
drg.PasteSpecial Paste:=xlPasteColumnWidths
srg.Copy drg
Dim r As Range
For Each r In drg.Rows
r.WrapText = True
If r.RowHeight < 40 Then r.RowHeight = 40
Next r
If you want the Selected range Unioned with row one, try this
Dim srg As Range
Dim src As Range
Dim arr As Range
Set src = Selection
For Each arr In src.Areas
If srg Is Nothing Then
Set srg = Application.Union(arr, arr.EntireColumn.Rows(1))
Else
Set srg = Application.Union(srg, arr, arr.EntireColumn.Rows(1))
End If
Next
Copy Header With Selection
New Solution
Option Explicit
Sub ExportSelection()
Const rRow As Long = 1
If Not TypeOf Selection Is Range Then Exit Sub
Dim rg As Range: Set rg = RefRangeAndRow(Selection, rRow)
'Debug.Print rg.Address
Dim frrg As Range: Set frrg = Intersect(rg, rg.Worksheet.Rows(rRow))
With Workbooks.Add(xlWBATWorksheet).Worksheets(1).Range("A1")
frrg.Copy
.Cells.PasteSpecial xlPasteColumnWidths
rg.Copy .Cells
End With
End Sub
Function RefRangeAndRow( _
ByVal mrg As Range, _
Optional ByVal RowNumber As Long = 1) _
As Range
Dim rrg As Range
Dim arg As Range
For Each arg In mrg.Areas
If rrg Is Nothing Then
Set rrg = arg.EntireColumn.Rows(RowNumber)
Else
Set rrg = Union(rrg, arg.EntireColumn.Rows(RowNumber))
End If
Next arg
If rrg Is Nothing Then
Set RefRangeAndRow = mrg
Else
Set RefRangeAndRow = Union(rrg, mrg)
End If
End Function
Initial Solution (Covers only ranges in the same columns)
Sub ExportSelectionInitial()
If Not TypeOf Selection Is Range Then Exit Sub
Dim dfCell As Range
With Selection
With Union(.EntireColumn.Rows(1), .Cells)
.Rows(1).Copy
Set dfCell = Workbooks.Add(xlWBATWorksheet) _
.Worksheets(1).Range("A1")
dfCell.PasteSpecial xlPasteColumnWidths
.Copy dfCell
End With
End With
With dfCell.CurrentRegion ' headers and data
Dim rrg As Range
For Each rrg In .Rows
rrg.WrapText = True
If rrg.RowHeight < 40 Then rrg.RowHeight = 40
Next rrg
With .Rows(1) ' headers
End With
With .Resize(.Rows.Count - 1).Offset(1) ' data
End With
With .Worksheet ' worksheet
Debug.Print .Name
With .Parent ' workbook
Debug.Print .Name
.Saved = True ' for easy closing when developing
End With
End With
End With
End Sub
I have a column of cells in one worksheet I want to verify against a column in another worksheet.
If there is a match, then I would like to add a comment.
However, when I try running the code, it does not add the comment as intended.
Comments highly appreciated!
Sub Checktabfour()
Dim i As Long
Dim j As Long
Dim k As Long
j = Sheets(5).Range("C" & Rows.Count).End(xlUp).Row
k = Sheets(4).Range("B" & Rows.Count).End(xlUp).Row
For i = 9 To k
If Cells(i, "B").Value <> "" And Cells(i, "B").Value = Sheets(5).Range("C" & j).Value Then
Cells(i, "D").Value = "Yes"
End If
Next i
End Sub
Add Comment If a Match (For Each ... Next, Application.Match)
This is a 'range study', it surely can be improved using arrays.
Adjust C2 (the Source Worksheet first row is unknown) appropriately.
Option Explicit
Sub CheckFourAgainstFive()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(5)
Dim slCell As Range: Set slCell = sws.Range("C" & sws.Rows.Count).End(xlUp)
Dim srg As Range: Set srg = sws.Range("C2", slCell)
Dim dws As Worksheet: Set dws = wb.Sheets(4)
Dim dlCell As Range: Set dlCell = dws.Range("B" & dws.Rows.Count).End(xlUp)
Dim drg As Range: Set drg = dws.Range("B9", dlCell)
Dim dCell As Range
Dim cValue As Variant
For Each dCell In drg.Cells
cValue = dCell.Value
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
If IsNumeric(Application.Match(cValue, srg, 0)) Then
dCell.EntireRow.Columns("D").Value = "Yes"
End If
End If
End If
Next dCell
End Sub