How do I copy a formula result?
I select which rows to keep in the worksheet "UI", by marking the rows with the value 1 in column B.
I assigned the following macro to a command button, which copies the selected rows to the worksheet "Output":
Private Sub CommandButton1_Click()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("UI")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Output")
For i = 2 To ws1.Range("B999").End(xlUp).Row
If ws1.Cells(i, 2) = "1" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
Next i
End Sub
As the values in the rows are the results of formulas, the results pasted in "Output" come back as invalid cell references.
Is there a way of copy-pasting as text?
You should use "xlPasteValues" property to avoid invalid cell references when values in the rows are the results of formulas. You can try to modify your code as follows:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = Sheets("UI")
Dim ws2 As Worksheet: Set ws2 = Sheets("Output")
For i = 2 To ws1.Range("B999").End(xlUp).Row
If ws1.Cells(i, 2) = "1" Then
ws1.Rows(i).Copy
ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
End If
Next i
End Sub
Copy Values of Rows with Criteria
It's not quite nifty, but efficient.
Adjust the values in the constants section.
The Code
Option Explicit
Private Sub CommandButton1_Click()
' Source
Const sName As String = "UI"
Const sFirstRow As Long = 2
Const Criteria As String = "1" ' 'Const Criteria as long = 1'?
' Destination
Const dName As String = "Output"
Const dCell As String = "A2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range (assuming 'UsedRange' starts in cell 'A1').
Dim rg As Range: Set rg = wb.Worksheets(sName).UsedRange
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rg.Value ' assuming 'rg' has at least two cells
Dim cCount As Long: cCount = UBound(Data, 2)
' Declare additional variables.
Dim cValue As Variant
Dim i As Long, j As Long, k As Long
' Loop and write matching values to the beginning of Data Array.
For i = sFirstRow To UBound(Data, 1)
cValue = Data(i, 2)
If Not IsError(cValue) Then
If cValue = Criteria Then
k = k + 1
For j = 1 To cCount
Data(k, j) = Data(i, j)
Next j
End If
End If
Next i
' Write matching values from Data Array to Destination Range.
If k > 0 Then
With wb.Worksheets(dName).Range(dCell)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count - .Column + 1).ClearContents
.Resize(k, cCount).Value = Data
End With
MsgBox "Data transferred.", vbInformation, "Success"
Else
MsgBox "No matches found.", vbExclamation, "Fail?"
End If
End Sub
Related
Bascially I have found the below formula which is perfect except it only filters duplicates out based on column A, whereas I only want the rows deleted if Col A, B and C are all duplicated.
Sub removeDupes()
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet 'This can be changed to a specific sheet: Worksheets("sheetName")
With ws
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1
If .Cells(i, 1).Value = .Cells(i + 1, 1).Value Then
.Rows(i).Delete
End If
Next i
End With
End Sub
How can I edit this code so it applies to 3 columns?
Remove Duplicates
Before
After
Option Explicit
Sub RemoveDupesShort()
With ActiveSheet.UsedRange
.Range("A3", .Cells(.Rows.Count, .Columns.Count)) _
.RemoveDuplicates (VBA.Array(1, 2, 3))
End With
MsgBox "Duplicates removed.", vbInformation
End Sub
Sub RemoveDupes()
' Define constants.
Const FirstCellAddress As String = "A3"
Dim DupeCols() As Variant: DupeCols = VBA.Array("A", "B", "C")
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' For worksheet 'Sheet1' in the workbook containing this code, instead use:
'Set ws = ThisWorkbook.Worksheets("Sheet1")
' Reference the range ('rg').
Dim rg As Range
With ws.UsedRange
Set rg = ws.Range(FirstCellAddress, .Cells(.Rows.Count, .Columns.Count))
End With
' Write the column numbers to a zero-based variant array ('Cols').
Dim cUpper As Long: cUpper = UBound(DupeCols)
Dim Cols() As Variant: ReDim Cols(0 To cUpper)
Dim c As Long
For c = 0 To cUpper
Cols(c) = ws.Columns(DupeCols(c)).Column
Next c
' Remove duplicates.
rg.RemoveDuplicates (Cols)
' Note that the array of column numbers also needs to be evaluated:
' '(Cols)' which is short for 'Evaluate(Cols)'
' Inform.
MsgBox "Duplicates removed.", vbInformation
End Sub
I use this VBA code which works very well. It searches in column A of an external Excel file for all the terms in column D, and replaces the matches, with the content of column B of the external file in the found row. So for instance:
if D5 matches A11 of the external file, then B11 from external file is written to D5.
I am now trying to modify it so that it still searches in column 4 for matches in column A of external file, but for any matches found, replaces the column E with column B of the external file. So:
If D5 matches A11, then B11 from external file is written to E5.
Well, I've tried many changes in the replace loop but it throws errors every time. I suppose I don't use the correct command!
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'This is the workbook from where code runs
Set thisWb = ThisWorkbook
Set thisWs = thisWb.Sheets("Sheet1")
'External file
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'Detect end row in Col A of Data.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Loop though Column A
For i = 1 To lRow
'... and perform replace action
thisWs.Columns(4).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub ```
Untested:
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet, n As Long
Dim i As Long, arrList, arrD, rngD As Range
Set thisWs = ThisWorkbook.Sheets("Sheet1") 'This is the workbook from where code runs
'get an array from the column to be searched
Set rngD = thisWs.Range("D1:D" & thisWs.Cells(Rows.Count, "D").End(xlUp).Row)
arrD = rngD.Value
'Open external file and get the terms and replacements as an array
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
With NameListWB.Worksheets("Sheet1")
arrList = .Range("A1:B" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For n = 1 To UBound(arrD, 1) 'check each value from ColD
For i = 1 To UBound(arrList, 1) 'loop over the array of terms to search for
If arrD(n, 1) = arrList(i, 1) Then 'exact match ?
'If InStr(1, arrD(n, 1), arr(i, 1)) > 0 Then 'partial match ?
rngD.Cells(n).Offset(0, 1).Value = arrList(i, 2) 'populate value from ColB into ColE
Exit For 'got a match so stop searching
End If
Next i
Next n
End Sub
A VBA Lookup (Application.Match)
Adjust (play with) the values in the constants section.
Compact
Sub VBALookup()
' Source
Const sPath As String = "E:\Data.xlsx"
Const sName As String = "Sheet1"
Const slCol As String = "A" ' lookup
Const svCol As String = "B" ' value
Const sfRow As Long = 2
' Destination
Const dName As String = "Sheet1"
Const dlCol As String = "D" ' lookup
Const dvCol As String = "E" ' value
Const dfRow As Long = 2
Application.ScreenUpdating = False
' Source
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data in lookup column range
Dim srCount As Long: srCount = slRow - sfRow + 1
Dim slrg As Range: Set slrg = sws.Cells(sfRow, slCol).Resize(srCount)
Dim svData As Variant
With slrg.EntireRow.Columns(svCol)
If srCount = 1 Then ' one cell
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = .Value
Else ' multiple cells
svData = .Value
End If
End With
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
If dlRow < dfRow Then Exit Sub ' no data in lookup column range
Dim drCount As Long: drCount = dlRow - dfRow + 1
Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dlCol).Resize(drCount)
Dim dData As Variant
If drCount = 1 Then ' one cell
ReDim dData(1 To 1, 1 To 1): dData(1, 1) = dlrg.Value
Else ' multiple cells
dData = dlrg.Value
End If
' Loop.
Dim srIndex As Variant
Dim dValue As Variant
Dim dr As Long
Dim MatchFound As Boolean
For dr = 1 To drCount
dValue = dData(dr, 1)
If Not IsError(dValue) Then
If Len(dValue) > 0 Then
srIndex = Application.Match(dValue, slrg, 0)
If IsNumeric(srIndex) Then MatchFound = True
End If
End If
If MatchFound Then
dData(dr, 1) = svData(srIndex, 1)
MatchFound = False
Else
dData(dr, 1) = Empty
End If
Next dr
' Close the source workbook.
swb.Close SaveChanges:=False
' Write result.
dlrg.EntireRow.Columns(dvCol).Value = dData
' Inform.
Application.ScreenUpdating = True
MsgBox "VBA lookup has finished.", vbInformation
End Sub
pls help, I need a excel vba code, which copies every second value of a row
and paste that into a column in another sheet
.
I tried it like this
Sub Test()
Worksheets("Sheet1").Activate
Dim x As Integer
For x = 5 To 196 Step 2
Worksheets("Tabelle1").Activate
Cells(x, 2).Value = Sheets("Sheets1").Range("E2:GN2")
Next x
End Sub
Sub test()
Dim WkSource As Worksheet
Dim WkDestiny As Worksheet
Dim i As Long
Dim j As Long
Dim LR As Long
Dim k As Long
Set WkSource = ThisWorkbook.Worksheets("Hoja1")
Set WkDestiny = ThisWorkbook.Worksheets("Hoja2")
With WkSource
LR = .Range("E" & .Rows.Count).End(xlUp).Row
k = 2 'starting row where you want to paste data in destiny sheet
For i = 2 To LR Step 1
For j = 5 To 12 Step 2 'j=5 to 12 because my data goes from column E to L (5 to 12)
WkDestiny.Range("D" & k).Value = .Cells(i, j).Value
k = k + 1
Next j
Next i
End With
Set WkSource = Nothing
Set WkDestiny = Nothing
End Sub
The code loop trough each row and each column (notice step 2 to skip columns)
Output I get:
you can start from something like this:
Option Explicit
Private Sub dataCp()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = wb.Sheets("Tabelle1")
Dim lrow As Long, lcol As Long, i As Long
Dim rng As Range, c As Range
lcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 5 To lcol
lrow = (ws2.Cells(ws2.Rows.Count, "D").End(xlUp).Row) + 1
ws2.Range("D" & lrow).Value = ws.Cells(2, i).Value
i = i + 1
Next
End Sub
Transpose Data
It will transpose all rows of a range in a worksheet to consecutive columns on another worksheet.
Since scStep is 2, in this case, only every other cell in each source row will be copied.
Adjust (play with) the values in the constants section.
Option Explicit
Sub TransposeData()
' Source
Const sName As String = "Sheet1"
Const sFirstRowAddress As String = "E2:GN2"
Const scStep As Long = 2
' Destination
Const dName As String = "Tabelle1"
Const dFirstCellAddress As String = "D2"
' Both
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source range to the source array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sData As Variant
Dim srCount As Long
With sws.Range(sFirstRowAddress)
' Populate data.
' With .Resize(20)
' .Formula = "=RANDBETWEEN(1,100)"
' .Value = .Value
' End With
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data in data range
srCount = lCell.Row - .Row + 1
sData = .Resize(srCount).Value
End With
' Define the destination array.
Dim scCount As Long: scCount = UBound(sData, 2)
Dim drCount As Long
drCount = Int(scCount / scStep) - CLng(scCount Mod scStep > 0)
Dim dData As Variant: ReDim dData(1 To drCount, 1 To srCount)
' Write the data from the source array to the destination array.
Dim r As Long, c As Long
For c = 1 To srCount
For r = 1 To drCount
dData(r, c) = sData(c, (r - 1) * scStep + 1)
Next r
Next c
' Write the values from the destination array to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, srCount) ' first row range
' Write data.
.Resize(drCount).Value = dData
' Clear below.
.Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
' Apply some formatting.
'.EntireColumn.AutoFit
End With
' Inform.
MsgBox "Data transposed.", vbInformation
End Sub
I'm trying to return the partial match string on a column right beside the column with the text I'm trying to search within. This is the code I tried to write. What would be a better way to do this?
Essentially I have a column with:
Column 1
aaaaa1111
...
zzzzz9999
Column 2
aaa
bbb
..
zzz
I want to return column 2 values to the column adjacent to column 1 where the column 2's string can be found within column 1.
Sub match()
Dim ws As Worksheet
Dim vendors As Range
Dim description As Range
Dim match As Range
Dim cell As Range
Dim j As Integer
Dim i As Integer
Set vendors = ws.Range("ae2:ae1007").Text
Set description = ws.Range("o2:o32609")
Set match = ws.Range("p2:p32609")
For i = 2 To 32609
For j = 2 To 1007
If InStr(description.Cells(i, "O"), vendors.Range(j, "AE")) > 0 Then
match.Cells(i, "P") = vendors.Range(j, "AE").Text
Else: match.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
Update: (I get run-time error '91' on line 9)
Sub match()
Dim ws As Worksheet
Dim cell As Range
Dim j As Integer
Dim i As Integer
For i = 2 To 32609
For j = 2 To 1007
If InStr(ws.Cells(i, "O"), ws.Cells(j, "AE")) > 0 Then
ws.Cells(i, "P") = ws.Cells(j, "AE").Text
Else: ws.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
You are getting error 91 because you declared ws but did not set ws to any worksheet.
The code below should run pretty fast since it process the data in an array (read/write from cells is a very slow process).
Option Explicit
Sub FindMatch()
Const vendorCol As String = "AE"
Const descCol As String = "O"
Const matchCol As String = "P"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
'==== Get a list of unique vendor names
Dim vendorDict As Object
Set vendorDict = CreateObject("Scripting.Dictionary")
vendorDict.CompareMode = vbTextCompare
Dim vendorLastRow As Long
Dim vendorInput As Variant
'Assign the values of the vendor names to array
vendorLastRow = ws.Cells(ws.Rows.Count, vendorCol).End(xlUp).Row
vendorInput = ws.Range(ws.Cells(2, vendorCol), ws.Cells(vendorLastRow, vendorCol)).Value
'Loop through the array and add to dictionary if it's not already in it
Dim n As Long
For n = 1 To UBound(vendorInput, 1)
If Not vendorDict.Exists(vendorInput(n, 1)) Then vendorDict.Add vendorInput(n, 1), 1
Next n
Dim vendorArr As Variant
vendorArr = vendorDict.keys
Set vendorDict = Nothing
Erase vendorInput
'====
'Assign the values of description to array
Dim descLastRow As Long
Dim descArr As Variant
descLastRow = ws.Cells(ws.Rows.Count, descCol).End(xlUp).Row
descArr = ws.Range(ws.Cells(2, descCol), ws.Cells(descLastRow, descCol)).Value
'Create an array of the same size as the description for match result, will be used to write in to the worksheet once at the end
Dim matchArr() As Variant
ReDim matchArr(1 To UBound(descArr, 1), 1 To 1) As Variant
'Loop through the description array and within the loop, check if there's a match in the vendor array
Dim i As Long
For i = 1 To UBound(descArr, 1)
For n = 0 To UBound(vendorArr)
If InStr(1, descArr(i, 1), vendorArr(n), vbTextCompare) <> 0 Then
'If match found, assign the vendor name to the match array
matchArr(i, 1) = vendorArr(n)
Exit For
End If
Next n
'If no match, return NA error
If matchArr(i, 1) = vbNullString Then matchArr(i, 1) = CVErr(xlErrNA)
Next i
ws.Cells(2, matchCol).Resize(UBound(matchArr, 1)).Value = matchArr
Erase descArr
Erase matchArr
End Sub
Compare Two Columns
This is a basic example that loops through column O and compares each value against each value in column AE. Match is no good because the values in AE need to be contained in O. You can always improve efficiency by using arrays as illustrated in Raymond Wu's answer.
On the other hand, you could loop through column AE and use the Find and FindNext methods to find all matches in column O which might also be more efficient.
Option Explicit
Sub MatchVendors()
' s - Source (read from ('vendors'))
' d - Destination (read from ('description') and written to ('match'))
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1") ' adjust, often...
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1") ' ... different
Dim slRow As Long: slRow = sws.Range("AE" & sws.Rows.Count).End(xlUp).Row
If slRow < 2 Then Exit Sub ' no data in source
Dim srg As Range: Set srg = sws.Range("AE2:AE" & slRow)
Dim dlRow As Long: dlRow = dws.Range("O" & dws.Rows.Count).End(xlUp).Row
If dlRow < 2 Then Exit Sub ' no data in destination
Dim drg As Range: Set drg = dws.Range("O2:O" & dlRow)
Application.ScreenUpdating = False
Dim sCell As Range
Dim dCell As Range
Dim IsMatch As Boolean
For Each dCell In drg.Cells
' Read (Search)
For Each sCell In srg.Cells
' Either 'contains'...
If InStr(1, dCell.Value, sCell.Value, vbTextCompare) > 0 Then
' ... or 'begins with':
'If InStr(1, dCell.Value, sCell.Value, vbTextCompare) = 1 Then
IsMatch = True
Exit For
End If
Next sCell
' Write
If IsMatch Then
dCell.EntireRow.Columns("P").Value = sCell.Value
IsMatch = False
Else
dCell.EntireRow.Columns("P").Value = "#N/A"
End If
Next dCell
Application.ScreenUpdating = True
MsgBox "Vendors matched to Descriptions.", vbInformation
End Sub
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