Can you help me with this Please, I'm trying to check if from range ("L2") to the end if result = "-" pop up a msgbox & colorize the range.
the conditions is all the cells value in the range horizontally must be = "-"
Example of what I mean:
I try to the below code but it's colorized all the value ("-") in the range
Sheets("Cumulated BOM").Activate
Dim i As Long
Dim c As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("L2", Range("L" & Row.Count).End(xlUp))
For Each myCell In myRange
c = c + 1
If (myCell) = "-" Then
myCell.Interior.Color = RGB(255, 87, 87)
i = i + 1
End If
Next myCell
Highlight Rows With All Their Cells Containing the Same Value
Option Explicit
Sub HighlightInvalidRows()
' Prepare.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Cumulated BOM")
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
' Write the number of columns of the range to a variable ('CellsCount').
Dim CellsCount As Long: CellsCount = rg.Columns.Count
' Each row of the range has this number of columns (cells).
' Remove all range colors.
rg.Interior.Color = xlNone
' Combine the rows ('rrg') to be highlighted
' into the Highlight range ('hrg').
' Declare variables that appear for the first time in the following loop.
Dim hrg As Range
Dim rrg As Range
Dim MatchCount As Long
' Loop through the rows of the range.
For Each rrg In rg.Rows
' Write the number of appearances of the value in the current row
' to a variable ('MatchCount').
MatchCount = Application.CountIf(rrg, "-")
' Compare the match count with the cells count.
If MatchCount = CellsCount Then ' the numbers are equal
' Combine the current row into the highlight range.
If hrg Is Nothing Then ' the first match
Set hrg = rrg
Else ' all other matches
Set hrg = Union(hrg, rrg)
End If
'Else ' the numbers are not equal; do nothing
End If
Next rrg
' Highlight the rows (in one go) and inform.
If hrg Is Nothing Then ' no matches found
MsgBox "No invalid rows found.", vbInformation
Else ' matches found
hrg.Interior.Color = RGB(255, 87, 87)
MsgBox "Invalid rows highlighted.", vbExclamation
End If
End Sub
Related
I am trying to learn vba and I have this list. For every NAME there will be an individual worksheet created. If the name of the worksheet match the name on the list I need to put the length in cell J1. I tried to use if ... elseif ... but knowing I have 430 different names the code will be too long what should I do? What alternative code can I use?
Sub length()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "A" Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = 4153
ElseIf ws.Name = "B" Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = 2273
Next
MsgBox "DONE"
End Sub
Sub length()
Dim Cell as Range
For Each Cell In Range("Name")
On Error Resume Next
ThisWorkbook.Sheets(Cell.Value).Range("J1") = Cell.Offset(0, 1)
If Err.Number <> 0 Then Debug.Print "Sheet " & Cell & " wasn't found"
On Error GoTo 0
Next Cell
MsgBox "DONE"
End Sub
Range("Name") needs to be changed to refer to the real range with the sheet names.
On Error ... can be removed if you're sure that all mentioned worksheets exist.
Write Values to Worksheets From a List
This will loop through the list of names. There may be worksheets whose names are not on the list.
Adjust the name of the worksheet containing the list (Sheet1) and the column (A) and row (2) of the first name.
Option Explicit
Sub CopyLengths()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
' Calculate the last row ('slRow'), the row of the last non-empty cell
' in the worksheet names column.
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
' Reference the source range ('srg'), the one-column range
' containing the worksheet names.
Dim srg As Range: Set srg = sws.Range("A2", sws.Cells(slRow, "A"))
Dim dws As Worksheet ' Destination Worksheet
Dim sCell As Range ' Current Source (Name) Cell
Dim sString As String ' Current Source String
' Copy lenghts.
' Loop through the cells ('sCell') of the source range...
For Each sCell In srg.Cells
' Convert the current cell's value to a string ('CStr')
' and write the string to a variable ('sString').
sString = CStr(sCell.Value)
' Check if the string is not an empty string...
If Len(sString) > 0 Then ' the cell is not blank
' Attempt to reference the worksheet named after the string.
On Error Resume Next
Set dws = wb.Worksheets(sString)
On Error GoTo 0
If Not dws Is Nothing Then ' worksheet found (referenced)
' Copy (write) the length.
dws.Range("J1").Value = sCell.Offset(, 1).Value
Set dws = Nothing ' reset the variable
'Else ' worksheet not found (not referenced); do nothing or e.g. ...
'Debug.Print "Worksheet '" & sString & "' not found"
End If
'Else ' the cell is blank; do nothing
End If
Next sCell
' Inform.
MsgBox "Lengths copied.", vbInformation
End Sub
Sub UpdateSheets()
Dim vTable As Variant
Dim iRow As Long
' SHEET_NAME: The sheets name containing the table: Name, LENGTH
' RANGE: the range where the sheet names are listed (without the header)
' vTable: the table with 'Name' & 'LENGTH' column values in memory
vTable = ThisWorkbook.Worksheets("SHEET_NAME").Range("I2:J7").Value2
For iRow = LBound(vTable, 1) To UBound(vTable, 1) ' iRow: current row in table
' vTable(iRow, 1): 'Name' column value
' vTable(iRow, 2): 'LENGTH' column value
On Error Resume Next
ThisWorkbook.Worksheets(CStr(vTable(iRow, 1))).Range("J1").Value2 = vTable(iRow, 2)
On Error GoTo 0
If Err.Number <> 0 Then
' DO SOMETHING IF ERROR IS THROWN (CREATE MISSING WORKSHEET)
Err.Clear
End If
Next iRow
MsgBox "DONE"
End Sub
If you have any questions don't hesitate!
Cheers, Peter.
Assuming that the columns are as on the image, you can do this:
Sub fnPickLength()
Dim ws As Excel.Worksheet
Dim oCell As Excel.Range
Dim oRng As Excel.Range
Set oRng = Range("rngTheNames") 'name the range with this name
For Each ws In ThisWorkbook.Worksheets
For Each oCell In oRng
If UCase(ws.Name) = UCase(oCell.Value) Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = oCell.Offset(0, 1).Value
Exit For
End If
Next
Next
MsgBox "DONE"
End Sub
Please adapt the named range as you want. I've choosen as "rngTheNames".
The ws name is compared with each oCell value. If matched, the Offset property reads the sibling cell of the evaluated name and put its value on the ws.
I have a worksheet. I want to clear the contents of cells 17-37, 45-60, 65-79; with the column being determined by the header (in Row 15) being equal to the value in Cell B1 of same worksheet. My sheet has columns C-Z to be looked at.
I tried to write a loop, or use other parts of code found online and I am unable to add the lookup so that it will only clear in the column if the value in row 15 of the column matches B1.
EDIT: Here is what I had so far, based on comments but it still will not find my value so cindex returns Error 2042 - checked for leading or trailing spaces.
Set ws to FORECAST
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("FORECAST")
'Set range to search
Dim hrg As Range
Set hrg = ws.Range("C15:Z15")
'set range to clear contents
Dim crg As Range
Set crg = ws.Range("17:37,45:60,65:79")
'Set header value to find
Dim Header As Variant
Header = ws.Range("B1").Value
'hold column where match is found
Dim cIndex As Variant
cIndex = Application.Match(Header, hrg, 0)
'validate column index and clear
If IsNumeric(cIndex) Then
Intersect(hrg.Cells(cIndex).EntireColumn, crg).Clear
'else no match found; no nothing
End If
End Sub
Clear Cells When Matching Header
Sub ClearColumn()
' Worksheet
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Header Range
Dim hrg As Range: Set hrg = ws.Range("C15:Z15")
' Clear-Entire-Rows Range
Dim crg As Range: Set crg = ws.Range("17:37,45:60,65:79")
' Header (Value)
Dim Header As Variant: Header = ws.Range("B1").Value
' Column Index (index of the matching cell (column)
' of the Header range (if a match))
Dim cIndex As Variant: cIndex = Application.Match(Header, hrg, 0)
' Validate the Column index and clear.
If IsNumeric(cIndex) Then ' match found
Intersect(hrg.Cells(cIndex).EntireColumn, crg).Clear
'Else ' no match found; do nothing
End If
End Sub
Solution
Sub ClearByHeaderName()
Dim criteriaCell As Range
Dim headerCells As Range
Dim headerCell As Range
Dim isColumnCleared As Boolean
Set criteriaCell = Range("B1")
If criteriaCell.Value = "" Then
MsgBox "Provide column name in B1!", vbExclamation
End
End If
Set headerCells = Range("C15:Z15")
For Each headerCell In headerCells
If headerCell.Value = criteriaCell.Value Then
ClearDataCells headerCell
isColumnCleared = True
End If
Next
If isColumnCleared Then
MsgBox "Done!", vbInformation
Else
MsgBox "Cannot find column '" & criteriaCell.Value & "'!", vbExclamation
End If
End Sub
Private Sub ClearDataCells(headerCell As Range)
With headerCell.EntireColumn
.Rows("17:37").Clear
.Rows("45:60").Clear
.Rows("65:79").Clear
End With
End Sub
I am currently using this code which goes through my worksheet and checks in the range O15:O300 to see if there are any cells that match the current date. If there is then it copies the entire row to worksheet "Today's Actions" then copies the site number (Situated in cell C3) to column AA in "Todays Actions".
I use the below code which works fine for this task for one specific sheet:
Sub rangecheck()
Application.ScreenUpdating = False
For Each cell In Range("O15:O300")
If cell.Value = Date Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Today's Actions").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveSheet.Range("C3").Copy
Sheets("Today's Actions").Range("AA" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True
End Sub
However, there are multiple sheets that I need to action this code for. So I use the below code to run this across all sheets:
Sub rangecheck_Set()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Call rangecheck
Next
starting_ws.Activate 'activate the worksheet that was originally active ("Today's Actions")
Application.ScreenUpdating = True
End Sub
This issue I'm having is that it seems to work fine but randomly whenever there are a lot of dates that match todays date in range O15:O300, it duplicates some lines up to or slightly exceeding 300 rows (So as an example, if there were 15 rows that 'should' be brought back to "Today's action" tab, it would bring them back but then have a few other rows randomly duplicated down to around row 300).
I get this might be due to the range going down to 300 but I even edited the range to go to 'last row' and it still brings back the same issue. Any thoughts? I've been trying to solve this for days now. Any help appreciated
Don't use implicit references to worksheets and ranges. It is most likely that this is the reason for your problem.
Also you don't need to select and copy - another source for unforeseeable errors.
Another reason for your error could be that you don't exclude "Today's Actions"-sheet from the copying routine.
I re-wrote your sub that is copying the data:
Sub copyTodaysRows(wsSource As Worksheet, wsTarget As Worksheet)
If wsSource is wsTarget then Exit Sub 'don't run this for the target sheet
Dim c As Range, wsTargetNewRow As Long
For Each c In wsSource.Range("O15:O300")
If c.Value = Date Then
With wsTarget
wsTargetNewRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
c.EntireRow.Copy Destination:=.Range("A" & wsTargetNewRow)
.Range("AA" & wsTargetNewRow).Value = wsSource.Range("C3").Value
End With
End If
Next
End Sub
It takes the source sheet and the target sheet as input parameters.
You will call it like this within your "outer" routine:
Sub rangecheck_Set()
Application.ScreenUpdating = False
Dim wsSource as worksheet
Dim wsTarget as worksheet
Set wsTarget = Thisworkbook.Worksheets("Today's Actions")
For Each wsSource In ThisWorkbook.Worksheets
copyTodaysRows wsSource, wsTarget
Next
Application.ScreenUpdating = True
End Sub
Copy Values of Criteria (Dates) Rows From Multiple Worksheets
Option Explicit
Sub RetrieveTodaysActions()
' Calls 'RetrieveTodaysActionsCall'.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet
For Each sws In ThisWorkbook.Worksheets
RetrieveTodaysActionsCall sws
Next sws
MsgBox "Today's actions retrieved.", vbInformation
End Sub
Sub RetrieveTodaysActionsCall(ByVal sws As Worksheet)
' Define constants.
' Source
Const sCriteriaColumnAddress As String = "O15:O300"
Const sCol1 As String = "A"
Const sCell2Address As String = "C3"
' Destination
Const dName As String = "Today's Actions"
Const dCol1 As String = "A"
Const dCol2 As String = "AA"
' Both
' Write the criteria date to a variable ('CriteriaDate').
Dim CriteriaDate As Date: CriteriaDate = Date ' today
' Exclude the destination worksheet.
If StrComp(sws.Name, dName, vbTextCompare) = 0 Then Exit Sub
' Reference the source criteria column range ('scrg').
Dim scrg As Range: Set scrg = sws.Range(sCriteriaColumnAddress)
' Check the number of matches, the number of rows to be copied
' to the destination worksheet.
If Application.CountIf(scrg, Date) = 0 Then Exit Sub
' Reference the range ('surg'), the range from the first cell
' in the source column ('sCol1') to the last cell of the used range.
Dim surg As Range
With sws.UsedRange
Set surg = sws.Range(sCol1 & 1, .Cells(.Rows.Count, .Columns.Count))
End With
' Reference the source range ('srg').
Dim srg As Range: Set srg = Intersect(scrg.EntireRow, surg)
If srg Is Nothing Then Exit Sub
' Write the number of columns of the source range to a variable (cCount).
Dim cCount As Long: cCount = srg.Columns.Count
' Write the criteria column number to a variable ('CriteriaColumn').
Dim CriteriaColumn As Long: CriteriaColumn = scrg.Column
' Write the values from the source range to an array ('Data').
Dim Data() As Variant: Data = srg.Value
Dim sValue As Variant ' Criteria Value in the Current Source Row
Dim sr As Long ' Current Source Row
Dim c As Long ' Current Source/Destination Column
Dim dr As Long ' Current Destination Row
' Loop through the rows of the array.
For sr = 1 To UBound(Data, 1)
' Write the value in the current row to a variable.
sValue = Data(sr, CriteriaColumn)
' Check if the current value is a date.
If IsDate(sValue) Then
' Check if the current value is equal to the criteria date.
If sValue = CriteriaDate Then
dr = dr + 1
' Write the values from the source row to the destination row.
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
Next sr
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = sws.Parent.Worksheets(dName)
' Reference the destination first cell ('dfCell').
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol1).End(xlUp).Offset(1)
' Reference the destination range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
' Write the values from the array to the destination range.
drg.Value = Data
' Reference the destination range 2 ('drg2').
Dim drg2 As Range: Set drg2 = drg.EntireRow.Columns(dCol2)
' Write the source cell 2 value to the destination range 2 ('drg2')
' (the same value to all cells of the range).
drg2.Value = sws.Range(sCell2Address).Value
End Sub
My process was different from the other responses, so I will still post it. I have also added a way of logging that a row has been logged because otherwise I saw that rows could be duplicated to the "Today's Actions" sheet.
Sub rangecheck(ByVal checkedSheet As Worksheet)
'#PARAM checkedSheet is the sheet to iterate through for like dates.
'Instantiate counter variables
Dim matchRow As Integer
matchRow = 0
Dim pasteRow As Integer
pasteRow = 0
Application.ScreenUpdating = False
For Each cell In checkedSheet.Range("O15:O300")
If cell.Value = Date Then
matchRow = cell.Row
'Checks if the row has been logged already (I use column "A" because I
'have no data in it, but this can be amy column in the row)
If checkedSheet.Cells(matchRow, 1) = "Logged" Then
'Do nothing
Else
'Sets value of "pasteRow" to one lower than the lowest used row in
column "AA"
pasteRow = Sheets("Today's Actions").Cells(Rows.Count,
27).End(xlUp).Row + 1
'Copies the values of the matchRow to the pasteRow
Sheets("Today's Actions").Rows(pasteRow).Value =
checkedSheet.Rows(matchRow).Value
'Copies the value of the Site Number to the paste row column "AA"
Sheets("Today's Actions").Cells(pasteRow, 27).Value =
checkedSheet.Cells(3, 3).Value
'Log that a row has been added to the "Today's Actions" sheet
checkedSheet.Cells(matchRow, 1) = "Logged"
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I have also modifed your sub which calls the copying sub to check if it is trying to copy the "Today's Actions" sheet.
Sub rangecheck_Set()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = Worksheets("Today's Actions")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
'Check if the ws to check is "Today's Actions"
If ws.Name = "Today's Actions" Then
'Do Nothing
Else
Call rangecheck(ws)
End If
Next
starting_ws.Activate 'activate the worksheet that was originally active
Application.ScreenUpdating = True
End Sub
So I have a worksheet called "gar_nv" containing in its first row some strings that I'd like to define as names for my columns. For instance, first cell of column A is "Number", I'd like to refer to the column A(starting from the second cell) as "Number" instead of column "A".
Sub NameCol()
Dim LastRow As Long
Dim x As Long, Rng As Range
With gar_nv
For x = 1 To .UsedRange.Columns.Count
LastRow = Cells(Cells.Rows.Count, x).End(xlUp).Row
Set Rng = Cells(2, x).Resize(LastRow)
.Names.Add Name:=Cells(1, x), RefersTo:=Rng
Set Rng = Nothing
Next
End With
End Sub
When I test my code like this, it throws a 91 error, what am I doing wrong?
Sub test()
With gar_nv
For Each Rng In .Range("Number")
MsgBox (Rng.Value)
Next
End With
End Sub
Create Names for Columns of Data
gar_nv is the code name of a worksheet in the workbook containing this code.
Option Explicit
Sub NameColumnsData()
' Delete all previous names in the worksheet.
'DeleteAllWorksheetNames gar_nv
Dim hrg As Range ' header range
Dim drg As Range ' data range
Dim cCount As Long ' number of columns
With gar_nv.UsedRange
Set hrg = .Rows(1)
Set drg = .Resize(.Rows.Count - 1).Offset(1)
cCount = .Columns.Count
End With
Dim crg As Range
Dim c As Long
Dim cTitle As String
For c = 1 To cCount
cTitle = hrg.Cells(c).Value
Set crg = drg.Columns(c)
gar_nv.Names.Add cTitle, crg
' Of course, you can lose the variables and just do:
'gar_nv.Names.Add hrg.Cells(c).Value, drg.Columns(c)
Next c
MsgBox "Column data names created.", vbInformation
End Sub
Sub NameColumnsDataTEST()
Dim cCell As Range
With gar_nv
For Each cCell In .Range("Number").Cells
' Caution! If there are many cells it may take 'forever'.
'MsgBox cCell.Address(0, 0) & ": " & cCell.Value
' Rather print to the Immediate window (Ctrl+G):
Debug.Print cCell.Address(0, 0) & ": " & cCell.Value
Next
End With
End Sub
Sub DeleteAllWorksheetNames(ByVal ws As Worksheet)
Dim nm As Name
For Each nm In ws.Names
Debug.Print nm.Name, nm.RefersTo, "Deleted!"
nm.Delete
Next nm
End Sub
The task I'm trying to accomplish is if Cells G21 to G27 have any text in them, then a vlookup formula will be pasted into the respective cell to the left of it
eg. Cell G31 has text so the formula =VLOOKUP(G31,Data!$P$2:$Q$110,2,FALSE) is in cell F31
This is the code I have so far, but I'm a beginner and I can't figure out how to insert the vlookup to automatically reference the cell next to it.
Private Sub Worksheet_Caps()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("G31:G27")
For Each cel In SrchRng
If cel.Value <> "" Then
cel.Offset(0, -1).Value= VLOOKUP(cel,Data!P2:Q110,2,FALSE)
End If
End Sub
VLookup vs Match
Both solutions will write values (not formulas) since you wrote "I originally wanted it to calculate in the VBA, but I couldn't figure that out!" in the comments.
A Quick Fix (Not Recommended)
Option Explicit
Sub Worksheet_Caps()
Dim SrchRng As Range: Set SrchRng = Range("G21:G27")
Dim LkpRng As Range: Set LkpRng = Worksheets("Data").Range("P2:Q110")
Dim SrchCell As Range
Dim MatchValue As Variant
For Each SrchCell In SrchRng.Cells
If Len(CStr(SrchCell.Value)) > 0 Then
MatchValue = Application.VLookup(SrchCell.Value, LkpRng, 2, False)
If Not IsError(MatchValue) Then
SrchCell.Offset(, -1).Value = MatchValue
'Else
'SrchCell.Offset(, -1).Value = Empty
End If
End If
Next SrchCell
End Sub
An Improvement
The following uses the more flexible Application.Match instead of any 'flavor' of VLookup.
Adjust (play with) the values in the constants section.
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Performs a 'VLookup' using 'Application.Match'.
' Remarks: Uses the 'RefColumn' and 'GetRange' functions.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WorksheetCaps()
On Error GoTo ClearError
' Source
Const sName As String = "Data" ' Worksheet Name
Const slFirst As String = "P2" ' First Lookup Cell Address
Const svCol As String = "Q" ' Value Column
' Destination
Const dName As String = "Sheet1" ' Worksheet Name
Const dlFirst As String = "G21" ' First Lookup Cell Address
Const dvCol As String = "F" ' Value Column
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Lookup Range ('slrg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slfCell As Range: Set slfCell = sws.Range(slFirst)
Dim slrg As Range: Set slrg = RefColumn(slfCell)
If slrg Is Nothing Then Exit Sub ' no data in source
' You can always use a static range instead of the previous 3 lines:
'Dim slrg As Range: Set slrg = sws.Range("P2:P110")
' Create a reference to the Destination Lookup Range ('dlrg').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlfCell As Range: Set dlfCell = dws.Range(dlFirst)
Dim dlrg As Range: Set dlrg = RefColumn(dlfCell)
If dlrg Is Nothing Then Exit Sub ' no data in destination
' You can always use a static range instead of the previous 3 lines:
'Dim dlrg As Range: Set dlrg = dws.Range("G21:G27")
' Create a reference to the Source Value Range ('svrg').
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
' Write the values from the Source Value Range
' to the Source Value Array ('svData').
Dim svData As Variant: svData = GetRange(svrg)
' Write the values from the Destination Lookup Range
' to the Destination Array ('dData').
Dim dData As Variant: dData = GetRange(dlrg)
' Declare additional variables.
Dim smrIndex As Variant ' Source Match Row Index
Dim dlValue As Variant ' Destination Lookup Value
Dim dr As Long ' Destination Row Counter
' Loop through the elements (rows) of the Destination Array.
For dr = 1 To UBound(dData, 1)
' Write the (lookup) value of the current element
' in the Destination Array to a variable ('dlValue').
dlValue = dData(dr, 1)
' Replace the (lookup) value of the current element
' in the Destination Array with 'Empty'.
dData(dr, 1) = Empty
If Not IsError(dlValue) Then ' not an error value
If Len(dlValue) > 0 Then ' not a blank
' Attempt to find a match of the current
' Destination Lookup value in the Source Lookup Range.
smrIndex = Application.Match(dlValue, slrg, 0)
If IsNumeric(smrIndex) Then ' a match (the first occurrence)
' Write the corresponding value (in the same row)
' of the Source Lookup Range in the Source Value Array
' to the current element in the Destination Array.
dData(dr, 1) = svData(smrIndex, 1)
'Else ' not a match (resulting in an error value)
End If
' Else ' a blank: Empty, ="", ',...
End If
' Else ' any error value
End If
Next dr
' Create a reference to the Destination Value Range ('dvrg').
Dim dvrg As Range: Set dvrg = dlrg.EntireRow.Columns(dvCol)
' Write the (modified) values from the Destination Array
' to the Destination Value Range (in one go).
dvrg.Value = dData
' Save the workbook.
wb.Save
' Inform the user.
MsgBox "The lookup has finished successfully.", _
vbInformation, "Worksheet Caps"
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
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
Please, try the next way:
If you need to place a formula to calculate Vlookup, use the next way:
cel.Offset(0, -1).Formula2 = "=Vlookup(" & cel.Address & ",Data!P2:Q110,2,False)"
You you need to calculate Vlookup in VBA, use the next alternative:
cel.Offset(0, -1).Value = WorksheetFunction.VLookup(cel.Value, Sheets("Data").Range("P2:Q110"), 2, False)
Edited:
Your whole code should should be adapted, in order to also deal with the case of no any match of VLookup function:
Private Sub Worksheet_Caps()
Dim SrchRng As Range, cel As Range, VLKresult
On Error Resume Next 'for the case of no any matched cells
Set SrchRng = Range("G31:G27").SpecialCells(xlCellTypeConstants) 'the range without empty cells
On Error GoTo 0
If Not SrchRng Is Nothing Then
For Each cel In SrchRng
VLKresult = Application.VLookup(cel.Value, Sheets("Data").Range("P$2:Q$110"), 2, False)
If Not IsError(VLKresult) Then
cel.Offset(0, -1).Value = VLKresult
Else
cel.Offset(0, -1).Value = "N/A"
End If
Next
End If
End Sub