How to replace values using Arrays & Ranges? - excel

I can replace values by mentioning them one by one.
I want to replace (oldarray) with (newarray) where both of them are derived from ranges.
i.e. oldarray = ("a2:a5") and newarray = ("b2:b5") instead of writing them one by one.
and also I need to replace each old value with adjacent cell value
i.e. a2 replaced by b2, and a3 replaced by b3.
is that possible?
Sub ReplaceValues()
Dim NewValues() As String
Dim NewValues() As String
OldValues = Split("BMV,MERCE", ",")
NewValues = Split("Jack,Sally", ",")
For i = 0 To UBound(OldValues)
With sheets("destination").Columns("Z:Z")
.Replace What:=OldValues(i), Replacement:=NewValues(i), LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
End With
Next
End Sub

Something like this should work:
Sub ReplaceValues()
Dim OldValues, NewValues, ws As Worksheet
Set ws = Thisworkbook.worksheets("Config") 'or whichever sheet...
OldValues = ws.Range("A2:A5").Value 'this gives a 2d array
NewValues = ws.Range("B2:B5").Value 'this too
For i = 1 To UBound(OldValues, 1)
With sheets("destination").Columns("Z:Z")
.Replace What:=OldValues(i, 1), Replacement:=NewValues(i, 1), _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
End With
Next
End Sub

Search and Replace (Application.Match)
If a value in the Destination column (Z) is found in the Search column (A), it will be replaced with the value in the same row of the Replace column (B).
This search (Application.Match) is not case-sensitive i.e. A = a.
Adjust the values in the constants section.
Only run replaceValues; the rest is being called by it.
The Code
Option Explicit
Sub replaceValues()
' Define constants.
' Source
Const srcName As String = "Sheet1"
Const sFirst As String = "A2"
Const rFirst As String = "B2"
' Destination
Const dstName As String = "Sheet2"
Const dFirst As String = "Z2"
' Workbook
Dim wb As Workbook
Set wb = ThisWorkbook
' Write from worksheets to arrays.
Dim ws As Worksheet ' Each Worksheet
Dim rng As Range ' Each Column Range
' Source
Dim sData As Variant ' Search Data Array
Dim rData As Variant ' Replace Data Array
Dim ColOffset As Long ' Search and Replace Column Offset
Set ws = wb.Worksheets(srcName)
Set rng = getColumnRange(getCellRange(ws, sFirst))
ColOffset = getCellRange(ws, rFirst).Column - rng.Column
sData = getColumn(rng)
rData = getColumn(rng.Offset(, ColOffset))
' Destination
Dim dData As Variant ' Destination Array
Set ws = wb.Worksheets(dstName)
Set rng = getColumnRange(getCellRange(ws, dFirst))
dData = getColumn(rng)
' Search and replace (in arrays).
Dim mData As Variant ' Match Data Array
mData = Application.Match(dData, sData, 0)
Dim cMatch As Variant
Dim i As Long
For i = 1 To UBound(dData, 1) ' or 'UBound(mData, 1)'
cMatch = mData(i, 1)
If IsNumeric(cMatch) Then
dData(i, 1) = rData(cMatch, 1)
End If
Next i
' Write from Destination Array to Destination Range.
rng.Value = dData
End Sub
Function getCellRange( _
ws As Worksheet, _
ByVal CellAddress As String) _
As Range
On Error Resume Next
Set getCellRange = ws.Range(CellAddress)
On Error GoTo 0
End Function
Function getColumnRange( _
FirstCell As Range) _
As Range
If Not FirstCell Is Nothing Then
With FirstCell
Dim rng As Range
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
If Not rng Is Nothing Then
Set getColumnRange = .Resize(rng.Row - .Row + 1)
End If
End With
End If
End Function
Function getColumn( _
rng As Range) _
As Variant
If Not rng Is Nothing Then
If InStr(rng.Address, ":") > 0 Then
getColumn = rng.Value
Else
Dim Data As Variant
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
getColumn = Data
End If
End If
End Function

The code below reads the data from A2:A6 into an array SrcArr and the data from B2:B6 into another array I called ModArr. Then it creates a third array (OutArr) of the same size as the source and writes data from SrcArr into it modified according to the data in ModArr. Finally, the OutArr is written to column D. This is the setup and the result.
And here is the code that did it.
Sub ReplaceArray()
' 138
Dim SrcArr As Variant ' Source
Dim ModArr As Variant ' Modifier
Dim OutArr As Variant ' Output
Dim R As Long ' loop counter: rows
With ActiveSheet
SrcArr = .Range("A2:A6").Value
ModArr = .Range("B2:B6").Value
ReDim OutArr(1 To UBound(SrcArr), 1 To UBound(SrcArr, 2))
For R = 1 To UBound(SrcArr)
If ModArr(R, 1) = True Then
OutArr(R, 1) = SrcArr(R, 1) * 12
Else
If IsEmpty(ModArr(R, 1)) Then
OutArr(R, 1) = "No data"
Else
OutArr(R, 1) = 0
End If
End If
Next R
.Cells(2, "D").Resize(UBound(SrcArr), UBound(SrcArr, 2)).Value = OutArr
End With
End Sub

Related

Find and paste values from one sheet to another in selected columns

I am trying to paste values from one sheet into another, both sheets have one unique column B "Bill ID".
I enter values in column p, q and w of sheet "reconciliation".
When I run the code it should paste these values in column p, q, w of bills sheet against same Bill ID, Bill ID in both sheets is in column 2.
One more thing, from reconciliation sheet for Bill ID, it should search only from b21 to last non empty row.
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsDisp As Worksheet: Set wsDisp = wb.Worksheets("Reconciliation")
Dim a As String
Dim b As String
Dim c As String
Dim e As Long
Dim F As String
Application.ScreenUpdating = False
a = wsDisp.Cells(19, 16).Value
b = wsDisp.Cells(19, 17).Value
c = wsDisp.Cells(19, 23).Value
e = MsgBox("Do You Wish to Save Recovery ? " & vbNewLine & "GIDC PAID = " & a & vbNewLine & "GST PAID = " & b & vbNewLine & " LPS PAID = " & c, vbYesNo)
If e = vbNo Then Exit Sub
For i = 21 To 400
Sheets("Bills").Cells(Cells(i, 2), 16) = Sheets("Reconciliation").Cells(i, 16)
Sheets("Bills").Cells(Cells(i, 2), 17) = Sheets("Reconciliation").Cells(i, 17)
Sheets("Bills").Cells(Cells(i, 2), 23) = Sheets("Reconciliation").Cells(i, 23)
Next
Application.ScreenUpdating = True
Reconciliation Sheet
Bills
Update Cells in Matching Rows
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Updates the 'Bills' worksheet.
' Calls: 'RefColumn','GetRange'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub UpdateBills()
' Source
Const sName As String = "Reconciliation"
Const sfRow As Long = 21
Const suCol As String = "B"
Const sColsList As String = "P,Q,W"
' Destination
Const dName As String = "Bills"
Const dfRow As Long = 2
Const duCol As String = "B"
Const dColsList As String = "P,Q,W"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Create references to the read-columns ('surg' and 'durg')
' and write only destination column to an array ('duData').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim surg As Range: Set surg = RefColumn(sws.Cells(sfRow, suCol))
If surg Is Nothing Then Exit Sub ' no data
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim durg As Range: Set durg = RefColumn(dws.Cells(dfRow, duCol))
If durg Is Nothing Then Exit Sub ' no data
' This is not done for the source because 'Application.Match'
' is multiple times faster on a range.
Dim duData As Variant: duData = GetRange(durg)
' Write values from the write-columns to jagged arrays.
' Split the lists (comma-separated strings) to arrays.
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim dCols() As String: dCols = Split(dColsList, ",")
Dim cUpper As Long: cUpper = UBound(sCols)
' Define the jagged arrays.
Dim sData As Variant: ReDim sData(0 To cUpper)
Dim dData As Variant: ReDim dData(0 To cUpper)
' Define destination empty array ('drData').
Dim drCount As Long: drCount = UBound(duData, 1)
Dim drData As Variant: ReDim drData(1 To drCount, 1 To 1)
Dim c As Long
' Write values from the source write-columns to the source jagged array,
' and destination empty arrays to destination jagged array.
For c = 0 To cUpper
sData(c) = GetRange(surg.EntireRow.Columns(sCols(c)))
dData(c) = drData
Next c
Erase drData
' Write matches from source (jagged) array ('sData')
' to destination (jagged) array ('dData').
Dim dr As Long
Dim sIndex As Variant
For dr = 1 To drCount
sIndex = Application.Match(duData(dr, 1), surg, 0)
If IsNumeric(sIndex) Then
For c = 0 To cUpper
dData(c)(dr, 1) = sData(c)(sIndex, 1)
Next c
End If
Next dr
Erase duData
Erase sData
' Write values from destination array tp destination ranges.
For c = 0 To cUpper
durg.EntireRow.Columns(dCols(c)).Value = dData(c)
Next c
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function

Combine data from multiple worksheets to one sheet on key word from column

im sorry for making similar question but im run into a problem, bcs i don t know very good VBA coding...
I found many similar questions, and i found a code that i can apply to my needs.
I found code here But i don't know how to edit that code so that he can work in my Workbook. I have workbook with 35 worksheets, all with same format, values are in columns "A:F", in column "E" i have text "On Stock" and "Sent", i want all rows from all worksheets that have "On Stock" value in column "E" to be copied into one worksheet named "Blanko List". I tried to edit code myself, but it can t run, nothing happens. Thanks in advance.
Edited code
Sub CommandButton4_Click()
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Sheets("Blanko List")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Blanko List" Then
y = 0
On Error Resume Next
y = Application.CountIf(ws.Columns(7), "On Stock")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(7)
Set c = .Find("On Stock", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
Application.CutCopyMode = False
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
''''
Original code:
Option Explicit
Sub GetYes()
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Sheets("Master")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Master" Then
y = 0
On Error Resume Next
y = Application.CountIf(ws.Columns(7), "Yes")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(7)
Set c = .Find("Yes", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
Application.CutCopyMode = False
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub
Copy Criteria Rows
Option Explicit
Sub CopyCriteriaRows()
' Source
Const sCols As String = "A:F"
Const sfRow As Long = 2
Const scCol As Long = 5
Const sCriteria As String = "On Stock"
' Destination
Const dName As String = "Blanco List"
Const dFirst As String = "A2"
' Exceptions
Const ExceptionsList As String = "Blanco List" ' add more
Const ListSeparator As String = ","
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the names of the worksheets to be 'processed' to an array.
Dim wsNames As Variant
wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator)
If IsEmpty(wsNames) Then Exit Sub ' no worksheet found
' Create a reference to the first destination row range.
' Note that the number of columns is equal in source and destination.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim cCount As Long: cCount = dws.Columns(sCols).Columns.Count
Dim drrg As Range: Set drrg = dws.Range(dFirst).Resize(, cCount)
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Source Range
Dim sfrrg As Range ' Source First Row Range
Dim drg As Range ' Destination Range
Dim Data As Variant ' Data Array
Dim cValue As Variant ' Current Value
Dim dr As Long ' Destination Row Counter
Dim sr As Long ' Source Row Counter
Dim c As Long ' Column Counter
For Each sws In wb.Worksheets(wsNames)
' Create a reference to the current Source First Row Range.
Set sfrrg = sws.Columns(sCols).Rows(sfRow)
Set srg = Nothing
' Create a reference to the current Source Range.
Set srg = RefColumns(sfrrg)
If Not srg Is Nothing Then ' the current Source Range is not empty
' Write the values from the current Source Range to the Data Array.
Data = GetRange(srg)
' Write the matches to the top of the Data Array. The size
' of the array stays the same but 'dr' is used: to track
' the number of, to move, and finally, to write (to the worksheet)
' the 'destination' values.
dr = 0
For sr = 1 To UBound(Data, 1)
cValue = Data(sr, scCol)
If StrComp(CStr(cValue), sCriteria, vbTextCompare) = 0 Then
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
Next sr
If dr > 0 Then ' there have been matches
' Create a reference to the Destination Range.
Set drg = drrg.Resize(dr)
' Write only the 'destination' values (dr) from
' the Data Array to the Destination Range.
drg.Value = Data
' Create a reference to the next Destination First Row Range.
Set drrg = drrg.Offset(dr)
End If
End If
Next sws
' The 'Clear Range' is the range spanning
' from the last 'Destination First Row Range'
' (which was referenced, but was not written to)
' to the bottom-most row range of the worksheet.
Dim crg As Range
Set crg = drrg.Resize(dws.Rows.Count - drrg.Row + 1)
crg.ClearContents
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the names of the worksheets of a workbook ('wb'),
' that are not included in a list ('ExceptionsList'),
' in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrWorksheetNames( _
ByVal wb As Workbook, _
Optional ByVal ExceptionsList As String = "", _
Optional ByVal ListSeparator As String = ",", _
Optional ByVal FirstIndex As Long = 0) _
As Variant
If wb Is Nothing Then Exit Function
Dim wsCount As Long: wsCount = wb.Worksheets.Count
If wsCount = 0 Then Exit Function ' There could e.g. only be charts.
Dim IndexDiff As Long: IndexDiff = FirstIndex - 1
Dim LastIndex As Long: LastIndex = wsCount + IndexDiff
Dim Arr() As String: ReDim Arr(FirstIndex To LastIndex)
Dim n As Long: n = IndexDiff
Dim ws As Worksheet
If Len(ExceptionsList) = 0 Then
For Each ws In wb.Worksheets
n = n + 1
Arr(n) = ws.Name
Next ws
Else
Dim Exceptions() As String
Exceptions = Split(ExceptionsList, ListSeparator)
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
n = n + 1
Arr(n) = ws.Name
End If
Next ws
End If
Select Case n
Case IndexDiff
Exit Function
Case Is < LastIndex
ReDim Preserve Arr(FirstIndex To n)
End Select
ArrWorksheetNames = Arr
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range spanning from the first row
' of a given range ('rg') to the row containing the bottom-most
' non-empty cell of the given range's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal rg As Range) _
As Range
If rg Is Nothing Then Exit Function
With rg.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim rData As Variant
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell only
ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
Else
rData = rg.Value
End If
GetRange = rData
End Function
' Irrelevant to the Question,
' but for a better understanding of `ArrWorksheetNames`.
Sub ArrWorksheetNamesTEST()
Const ExceptionsList As String = "Sheet1,Sheet2,Sheet3,Sheet4"
Const ListSeparator As String = ","
Const FirstIndex As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsNames As Variant
wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator, FirstIndex)
If IsEmpty(wsNames) Then
Debug.Print "No worksheets."
Else
Debug.Print "[" & LBound(wsNames) & "," & UBound(wsNames) & "]" _
& vbLf & Join(wsNames, vbLf)
End If
End Sub
You can use this to develop an array of values and then dump them into some collection sheet.
Sub grabAllSheets()
Const exclude_Sheet = "Result" ' name of sheet to drop data
Const tangoText = "On Stock"
Dim ws As Worksheet, aCell As Range
ReDim allvalues(1 To 6, 1 To 1)
Dim i As Long, c As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> exclude_Sheet Then
For Each aCell In Intersect(ws.Range("E:E"), ws.UsedRange).Cells
If aCell.Value = tangoText Then
i = i + 1
ReDim Preserve allvalues(1 To 6, 1 To i)
For c = 1 To Range("F:F").Column
allvalues(c, i) = ws.Cells(aCell.Row, c).Value
Next c
End If
Next aCell
End If
Next ws
Dim theRow As Long
With Sheets(exclude_Sheet)
theRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(IIf(theRow = 1, 1, theRow + 1), 1).Resize(i, 6).Value = _
Application.WorksheetFunction.Transpose(allvalues)
End With
End Sub

How to delete duplicates and original values if the duplicates are located in another worksheet

I'm seeking guidance on how to create a macro that can delete duplicate and original values if the duplicates are located in another worksheet. Here is an example of the workbook:
Sheet1
Class People
cs101 12
cs102 13
cs102 13
Sheet2
People Class
12 cs101
15 cs105
Sheet3
Room People Class
key1 12 cs101
key2 16 cs106
In this dataset, I want to remove rows that have "cs101" in all 3 worksheets, but I don't want to remove "cs102" since the duplicate is listed on the same worksheet.
The code below will help me on deleting duplicates and original values across multiple worksheets, but it will remove "cs102" row as well. Any guidance is appreciated, thank you.
Option Explicit
Sub RemoveDupes()
Const wsNamesList As String = "Sheet1,Sheet2,Sheet3"
Const HeaderTitle As String = "Class"
Const HeaderRow As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
Dim nUpper As Long: nUpper = UBound(wsNames)
Dim cRanges() As Range: ReDim cRanges(0 To nUpper)
Dim cData() As Variant: ReDim cData(0 To nUpper)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' A = a
Dim ws As Worksheet
Dim crg As Range
Dim hCell As Range
Dim n As Long
For n = 0 To nUpper
' Attempt to create a reference to the worksheet ('ws').
Set ws = RefWorksheet(wb, wsNames(n))
If Not ws Is Nothing Then
' Attempt to create a reference to the header cell ('hCell').
Set hCell = RefHeader(ws, HeaderTitle, HeaderRow)
If Not hCell Is Nothing Then
' Attempt to create a reference to the range ('crg').
Set crg = RefColumnRange(hCell.Offset(1))
If Not crg Is Nothing Then
' Store the range in an array ('cRanges').
Set cRanges(n) = crg
' Write the values from the ranges to an array ('cData').
cData(n) = GetColumnRange(crg)
' Write and count the unqiue values from the array
' to a dictionary ('dict').
FirstColumnToDictionaryWithCount dict, cData(n)
End If
End If
End If
Next n
Dim drg() As Range: ReDim drg(0 To nUpper)
Dim r As Long
' Combine all cells containing duplicates (and the originals)
' into one range ('drg()') per worksheet.
For n = 0 To nUpper
If Not cRanges(n) Is Nothing Then
For r = 1 To UBound(cData(n), 1)
If dict(cData(n)(r, 1)) > 1 Then
Set drg(n) = GetCombinedRange(drg(n), cRanges(n).Cells(r))
End If
Next r
End If
Next n
Application.ScreenUpdating = True
' Delete the entire rows of the ranges in one go per worksheet.
For n = 0 To nUpper
If Not drg(n) Is Nothing Then
drg(n).EntireRow.Delete
End If
Next n
Application.ScreenUpdating = False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a workbook ('wb'), creates a reference to the worksheet
' named after a value ('WorksheetName').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefWorksheet( _
ByVal wb As Workbook, _
ByVal WorksheetName As String) _
As Worksheet
If wb Is Nothing Then Exit Function
On Error Resume Next
Set RefWorksheet = wb.Worksheets(WorksheetName)
On Error GoTo 0
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet's ('ws') row ('HeaderRow'), creates a reference
' to the cell containing a value ('Title').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefHeader( _
ByVal ws As Worksheet, _
ByVal Title As String, _
Optional ByVal HeaderRow As Long = 1) _
As Range
If ws Is Nothing Then Exit Function
If HeaderRow < 1 Then Exit Function
If HeaderRow > ws.Rows.Count Then Exit Function
Dim hCell As Range
With ws.Rows(HeaderRow)
Set hCell = .Find(Title, .Cells(.Cells.Count), xlFormulas, xlWhole)
End With
If hCell Is Nothing Then Exit Function
Set RefHeader = hCell
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a one-column range from a cell
' ('FirstCellRange') to the bottom-most non-empty cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumnRange( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
Dim lCell As Range
With FirstCellRange.Cells(1)
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumnRange = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a one-column range ('ColumnRange')
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
ByVal ColumnRange As Range) _
As Variant
If ColumnRange Is Nothing Then Exit Function
Dim rCount As Long: rCount = ColumnRange.Rows.Count
Dim cData As Variant
With ColumnRange.Columns(1)
If rCount = 1 Then
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = .Value
Else
cData = .Value
End If
End With
GetColumnRange = cData
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Appends the unique values and their count of the first column
' of a 2D one-based array ('cData') to a dictionary ('dict').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FirstColumnToDictionaryWithCount( _
ByRef dict As Object, _
ByVal cData As Variant)
If dict Is Nothing Then Exit Sub
If IsEmpty(cData) Then Exit Sub
Dim cValue As Variant
Dim r As Long
For r = 1 To UBound(cData, 1)
cValue = cData(r, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
dict(cValue) = dict(cValue) + 1
End If
End If
Next r
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Combines two ranges into one range.
' Note that the ranges have to be located in the same worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCombinedRange( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range) _
As Range
If BuiltRange Is Nothing Then
Set GetCombinedRange = AddRange
Else
Set GetCombinedRange = Union(BuiltRange, AddRange)
End If
End Function
With all due respect to those who would employ dictionaries and classes, I think this can be resolved with more pedestrian methods. The code below applies the logic that if a "Class ID" from Sheet1 is found in either Sheet2 or Sheet3 (or both) it should be deleted there and in Sheet1.
Option Explicit
Sub RemoveDuplicates()
' 291
' change the tab names to match actual names
' use Chr(124) vertical bar as separator
Const TabNames As String = "Sheet1|Sheet2|Sheet3"
' "Class" is in column A on Sheet1, column B on Sheet2 and column C on Sheet3
Const ClassClm As String = "A,B,C"
Const FirstRow As Long = 2 ' same on all sheets
Dim Ws() As Worksheet
Dim Clm() As Long ' columns in which "Class" is found
Dim Rng() As Range ' used ranges in Ws()
Dim Idx As Integer ' index of Ws(), Rng() and Clm()
Dim Fnd As Range ' found duplicate's cell
Dim Del As Boolean ' deletopn tok place
Dim Tmp As Variant ' helper
Dim R As Long ' loop counter: rows of Ws(1)
Tmp = Split(TabNames, "|")
ReDim Ws(1 To UBound(Tmp) + 1)
ReDim Clm(1 To UBound(Tmp) + 1)
ReDim Rng(1 To UBound(Tmp) + 1)
For Idx = 1 To UBound(Ws)
Set Ws(Idx) = ThisWorkbook.Worksheets(Tmp(Idx - 1))
Clm(Idx) = Columns(Split(ClassClm, ",")(Idx - 1)).Column
Next Idx
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
SetSheetRanges Rng, Ws, Clm
For R = Rng(1).Rows.Count To FirstRow Step -1
For Idx = 2 To UBound(Ws)
Set Fnd = Rng(Idx).Find(Rng(1).Cells(R).Value, _
LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
With Fnd
.Worksheet.Rows(.Row).Delete
End With
SetSheetRanges Rng, Ws, Clm, Idx
Del = True
End If
Next Idx
If Del Then
Ws(1).Rows(R).Delete
SetSheetRanges Rng, Ws, Clm, 1
Del = False
End If
Next R
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub SetSheetRanges(Fun() As Range, _
Ws() As Worksheet, _
Clm() As Long, _
Optional ByVal Idx As Integer)
' 291
Dim i As Integer ' index of Ws()
Dim Rl As Long
For i = LBound(Ws) To UBound(Ws)
If (i = Idx) Or (Idx = 0) Then
With Ws(i)
Rl = .Cells(.Rows.Count, Clm(i)).End(xlUp).Row
Set Fun(i) = .Range(.Cells(1, Clm(i)), .Cells(Rl, Clm(i)))
End With
End If
Next i
End Sub
How about a dictionary of class ID's whose values are the number of sheets on which the class exists, and another dictionary that tests if the class has already been counted for any worksheet? Something like:
Dim oWS As Worksheet
Dim oClassRange As Range
Dim oClass As Range
Dim oClasses As Object: Set oClasses = CreateObject("Scripting.Dictionary")
Dim oWSClass As Object
For Each oWS in ThisWorkbook
'start with a blank dictionary for each worksheet
Set oWSClass = CreateObject("Scripting.Dictionary")
Set oClassRange = {define the range with class ID's}
For Each oClass In oClassRange
sID = oClass.Value2
If Not oWSClass.Exists(sID) Then 'only add or increment if it's the first time class appears on this worksheet
oWSClass.Add sID, 1
If oClasses.Exists(sID) Then oClasses(sID) = oClasses(sID) + 1 _
Else oClasses.Add sID, 1
End If
Next oClassRange
Next oWS
Then iterate the oClasses dictionary entries, and any value of 3 triggers deleting the rows from each worksheet.

How to delete duplicate values and original values across multiple sheets in excel

I'm a beginner on VBA and I'm seeking advice on how to create a macro that can remove duplicate values (by deleting rows) including the original values itself on multiple sheets. In addition, the macro can search for the specific value even though the specific value is listed on different columns. Here is an example of the sheets:
Sheet1
Class People
cs101 12
cs102 13
Sheet2
People Class
12 cs101
15 cs105
Sheet3
Room People Class
key1 12 cs101
key2 16 cs106
In this dataset, I want to remove rows that have identical class codes (cs101) in multiple sheets.
Here is the macro that I have created:
Sub Remove_Duplicates()
Dim Rng As Range
Set Rng = Range("A1:A1048576")
Rng.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
The issues in this macro are:
This macro only works on 1 sheet
This macro removes the duplicates, but not the original value
This macro can only be used on values that are listed in column A
Thank you for your time!
Remove Duplicates and Originals in Multiple Worksheets
Option Explicit
Sub RemoveDupes()
Const wsNamesList As String = "Sheet1,Sheet2,Sheet3"
Const HeaderTitle As String = "Class"
Const HeaderRow As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
Dim nUpper As Long: nUpper = UBound(wsNames)
Dim cRanges() As Range: ReDim cRanges(0 To nUpper)
Dim cData() As Variant: ReDim cData(0 To nUpper)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' A = a
Dim ws As Worksheet
Dim crg As Range
Dim hCell As Range
Dim n As Long
For n = 0 To nUpper
' Attempt to create a reference to the worksheet ('ws').
Set ws = RefWorksheet(wb, wsNames(n))
If Not ws Is Nothing Then
' Attempt to create a reference to the header cell ('hCell').
Set hCell = RefHeader(ws, HeaderTitle, HeaderRow)
If Not hCell Is Nothing Then
' Attempt to create a reference to the range ('crg').
Set crg = RefColumnRange(hCell.Offset(1))
If Not crg Is Nothing Then
' Store the range in an array ('cRanges').
Set cRanges(n) = crg
' Write the values from the ranges to an array ('cData').
cData(n) = GetColumnRange(crg)
' Write and count the unqiue values from the array
' to a dictionary ('dict').
FirstColumnToDictionaryWithCount dict, cData(n)
End If
End If
End If
Next n
Dim drg() As Range: ReDim drg(0 To nUpper)
Dim r As Long
' Combine all cells containing duplicates (and the originals)
' into one range ('drg()') per worksheet.
For n = 0 To nUpper
If Not cRanges(n) Is Nothing Then
For r = 1 To UBound(cData(n), 1)
If dict(cData(n)(r, 1)) > 1 Then
Set drg(n) = GetCombinedRange(drg(n), cRanges(n).Cells(r))
End If
Next r
End If
Next n
Application.ScreenUpdating = True
' Delete the entire rows of the ranges in one go per worksheet.
For n = 0 To nUpper
If Not drg(n) Is Nothing Then
drg(n).EntireRow.Delete
End If
Next n
Application.ScreenUpdating = False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a workbook ('wb'), creates a reference to the worksheet
' named after a value ('WorksheetName').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefWorksheet( _
ByVal wb As Workbook, _
ByVal WorksheetName As String) _
As Worksheet
If wb Is Nothing Then Exit Function
On Error Resume Next
Set RefWorksheet = wb.Worksheets(WorksheetName)
On Error GoTo 0
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet's ('ws') row ('HeaderRow'), creates a reference
' to the cell containing a value ('Title').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefHeader( _
ByVal ws As Worksheet, _
ByVal Title As String, _
Optional ByVal HeaderRow As Long = 1) _
As Range
If ws Is Nothing Then Exit Function
If HeaderRow < 1 Then Exit Function
If HeaderRow > ws.Rows.Count Then Exit Function
Dim hCell As Range
With ws.Rows(HeaderRow)
Set hCell = .Find(Title, .Cells(.Cells.Count), xlFormulas, xlWhole)
End With
If hCell Is Nothing Then Exit Function
Set RefHeader = hCell
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a one-column range from a cell
' ('FirstCellRange') to the bottom-most non-empty cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumnRange( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
Dim lCell As Range
With FirstCellRange.Cells(1)
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumnRange = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a one-column range ('ColumnRange')
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
ByVal ColumnRange As Range) _
As Variant
If ColumnRange Is Nothing Then Exit Function
Dim rCount As Long: rCount = ColumnRange.Rows.Count
Dim cData As Variant
With ColumnRange.Columns(1)
If rCount = 1 Then
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = .Value
Else
cData = .Value
End If
End With
GetColumnRange = cData
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Appends the unique values and their count of the first column
' of a 2D one-based array ('cData') to a dictionary ('dict').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FirstColumnToDictionaryWithCount( _
ByRef dict As Object, _
ByVal cData As Variant)
If dict Is Nothing Then Exit Sub
If IsEmpty(cData) Then Exit Sub
Dim cValue As Variant
Dim r As Long
For r = 1 To UBound(cData, 1)
cValue = cData(r, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
dict(cValue) = dict(cValue) + 1
End If
End If
Next r
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Combines two ranges into one range.
' Note that the ranges have to be located in the same worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCombinedRange( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range) _
As Range
If BuiltRange Is Nothing Then
Set GetCombinedRange = AddRange
Else
Set GetCombinedRange = Union(BuiltRange, AddRange)
End If
End Function
Option Explicit
Sub DeleteDuplRows()
'https://stackoverflow.com/questions/68342367/ _
how-to-delete-duplicate-values-and-original-values-across-multiple-sheets-in-exc
Dim wb As Workbook, wShs As Object
Dim i As Long, Col As Range, ColRange() As Range, ColRangeStr As String
Dim ColRangeStrArr() As String, str As Variant, Cl As Range, ShtDelRange As Range
Dim ClassNames As Object
Set ClassNames = CreateObject("Scripting.Dictionary")
Dim DuplClassNames As Object
Set DuplClassNames = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set wShs = wb.Worksheets
ReDim ColRange(1 To wShs.Count)
'Make ColRange array of ranges for "Class" column from each sheet
For i = 1 To wShs.Count
Set Col = wShs(i).Rows(1).Find("Class")
If Not Col Is Nothing Then
Set ColRange(i) = wShs(i).Range(wShs(i).Cells(2, Col.Column), _
wShs(i).Cells(wShs(i).UsedRange.Rows.Count, Col.Column))
End If
Next i
'Make ColRangeStr string of values of cells from each range element of the above ColRange array,
ColRangeStr = ""
For i = LBound(ColRange) To UBound(ColRange)
ColRangeStr = ColRangeStr & "," & Join(Application.Transpose(Application.Index( _
ColRange(i), 0, 1)), ",")
Next i
ColRangeStr = Right(ColRangeStr, Len(ColRangeStr) - 1)
'Split the ColRangeStr string into ColRangeStrArr array
ColRangeStrArr = Split(ColRangeStr, ",")
'Make DuplClassNames dictionary of duplicate values from the above ColRangeStrArr array
With ClassNames
.CompareMode = TextCompare
For Each str In ColRangeStrArr
If Not Len(str) = 0 Then
If Not .Exists(str) Then
.Add str, Nothing
Else
If Not DuplClassNames.Exists(str) Then DuplClassNames.Add str, Nothing
End If
End If
Next str
End With
'Make ShtDelRange union of DUPLICATE cells from "class" column of each sheet if the cell value _
exists in DuplClassNames dictionary.
For i = LBound(ColRange) To UBound(ColRange)
Set ShtDelRange = Nothing
For Each Cl In ColRange(i)
If DuplClassNames.Exists(Cl.Value) Then
If ShtDelRange Is Nothing Then
Set ShtDelRange = Cl
Else
Set ShtDelRange = Union(ShtDelRange, Cl)
End If
End If
Next Cl
'Delete entire rows of the Sheets(i) if the cells are in ShtDelRange
If Not ShtDelRange Is Nothing Then ShtDelRange.EntireRow.Delete
Next i
End Sub

Change the value of each cell that meets criteria in a column

I am trying to change the value of each cell in column 7 that meets criteria. So far I managed to change the value with one criteria but I would like to add up to 14 criteria. Thanks for your help
Sub ChangeValue()
Dim i As Integer
Dim WK As Worksheet
Dim rg1 As range
Dim rg2 As range
Set WK = Sheet4
Set rg1 = range("AB2")
Set rg2 = range("AB3")
For i = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1
If Cells(i, 7).Value = rg1 Then
Cells(i, 7).Value = rg2.Value
End If
Next i
End Sub
I would like to have more conditions something like if = AB3 change to AB4 if= AB4 Change to AB5 and so on...
To create a variable list of value/replace value pairs I would suggest using a dictionary:
Option Explicit
Sub ChangeValue()
Dim d
Set d = CreateObject("Scripting.Dictionary")
Dim r_test_value As Range
Dim r_anchor As Range
Set r_anchor = Range("AB2")
'need at least 2 values
If Not IsEmpty(r_anchor) And Not IsEmpty(r_anchor.Offset(1, 0)) Then
Set r_test_value = Range(r_anchor, _
Cells(Rows.Count, r_anchor.Column).End(xlUp).Offset(-1, 0))
Debug.Print r_test_value.Address
Dim i As Long
i = 0
Dim r As Range
For Each r In r_test_value
d.Add r.Value, r.Offset(i+1, 0).Value
i = i + 1
Next r
For i = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1
If d.exists(Cells(i, 7).Value) Then
Cells(i, 7).Value = d.Item(Cells(i, 7).Value)
End If
Next i
End If
End Sub
Search and Replace Cell Values
EDIT
This is a more appropriate solution.
Adjust the starting rows i.e. For i = ? and For k = ?
Second Answer
Sub replaceValues()
' Determine Source Last Row.
Dim sLastRow As Long
sLastRow = Sheet4.Cells(Sheet4.Rows.Count, "AB").End(xlUp).Row
' Determine Destination Last Row.
Dim dLastRow As Long
dLastRow = Sheet4.Cells(Sheet4.Rows.Count, "G").End(xlUp).Row
Dim i As Long ' Destination Range Rows Counter
Dim k As Long ' Source Rows Counter
' Loop through rows of Destination Range.
For i = 2 To dLastRow
' Loop through rows of Source Range.
For k = 1 To sLastRow - 1
' When a value is found...
If Sheet4.Cells(i, "G").Value = Sheet4.Cells(k, "AB").Value Then
' ... replace it with the value below.
Sheet4.Cells(i, "G").Value = Sheet4.Cells(k + 1, "AB").Value
Exit For ' Value has been found and replaced. Stop searching.
' Otherwise you'll end up with the last replace value.
End If
Next k
Next i
' Inform.
MsgBox "Values replaced.", vbInformation, "Success"
End Sub
The First Answer (misunderstood)
The first solution is for using worksheet code names. It can be used for two worksheets. It is one in your case (Sheet4).
The second solution shows how to use it in two worksheets using worksheet names.
The code will loop through a column range of values and replace each value found in a row range of 'search values' with an associated 'replace value' in another same sized row range (in this case the ranges are adjacent, one below the other).
The Code
Option Explicit
Sub replaceValuesWorksheetCodeNames()
' Source
' Make sure the following two are of the same size.
Const srcAddress As String = "AB2:AO2"
Const rplAddress As String = "AB3:AO3"
' Destination
Const dFirstCell As String = "G2"
' Write Source Row Ranges to Source Arrays (Search and Replace).
With Sheet4
Dim srcData As Variant: srcData = .Range(srcAddress).Value
Dim rplData As Variant: rplData = .Range(rplAddress).Value
End With
' Define Destination Column Range.
Dim rg As Range
Dim RowOffset As Long
With Sheet4.Range(dFirstCell)
RowOffset = .Row - 1
Set rg = .Resize(.Worksheet.Rows.Count - RowOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
If rg Is Nothing Then Exit Sub
Set rg = .Resize(rg.Row - RowOffset)
End With
' Write values from Destination Column Range to Data Array.
Dim rCount As Long: rCount = rg.Rows.Count
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data = rg.Value
End If
' Search and replace values in Data Array.
Dim cValue As Variant
Dim cIndex As Variant
Dim i As Long
For i = 1 To rCount
cValue = Data(i, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
cIndex = Application.Match(cValue, srcData, 0)
If IsNumeric(cIndex) Then
' When the replace data is in a row range.
Data(i, 1) = rplData(1, cIndex)
' When the replace data is in a column range.
'Data(i, 1) = rplData(cIndex, 1)
End If
End If
End If
Next i
' Write possibly modified values from Data Array back
' to Destination Column Range.
rg.Value = Data
' Inform.
MsgBox "Values replaced.", vbInformation, "Success"
End Sub
Sub replaceValuesWorksheetNames()
' Source
Const sName As String = "Sheet1"
' Make sure the following two are of the same size.
Const srcAddress As String = "AB2:AO2"
Const rplAddress As String = "AB3:AO3"
' Destination
Const dName As String = "Sheet2"
Const dFirstCell As String = "G2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Write Source Row Ranges to Source Arrays (Search and Replace).
With wb.Worksheets(sName)
Dim srcData As Variant: srcData = .Range(srcAddress).Value
Dim rplData As Variant: rplData = .Range(rplAddress).Value
End With
' Define Destination Column Range.
Dim rg As Range
Dim RowOffset As Long
With wb.Worksheets(dName).Range(dFirstCell)
RowOffset = .Row - 1
Set rg = .Resize(.Worksheet.Rows.Count - RowOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
If rg Is Nothing Then Exit Sub
Set rg = .Resize(rg.Row - RowOffset)
End With
' Write values from Destination Column Range to Data Array.
Dim rCount As Long: rCount = rg.Rows.Count
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data = rg.Value
End If
' Search and replace values in Data Array.
Dim cValue As Variant
Dim cIndex As Variant
Dim i As Long
For i = 1 To rCount
cValue = Data(i, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
cIndex = Application.Match(cValue, srcData, 0)
If IsNumeric(cIndex) Then
' When the replace data is in a row range.
Data(i, 1) = rplData(1, cIndex)
' When the replace data is in a column range.
'Data(i, 1) = rplData(cIndex, 1)
End If
End If
End If
Next i
' Write possibly modified values from Data Array back
' to Destination Column Range.
rg.Value = Data
' Inform.
MsgBox "Values replaced.", vbInformation, "Success"
End Sub

Resources