Copy & Paste values if cell value = "N/A" - excel

I want to copy and paste values to a range of cells but only if their value = "N/A". I want to leave the formulas as they are in all the cells that do not = "N/A".
In context, I have hundreds of VLOOKUPs. Example:
=IFERROR(VLOOKUP("L0"&MID(G$4,1,1)&"A0"&MID(G$4,1,1)&MID(G$4,3,2)&"-0"&$B6,Sheet1!$C:$D,2,FALSE),"N/A")
Is this possible with VBA?

First of all, you should use real error values rather than string that only look like errors. Secondly, VLOOKUP returns the N/A error directly if the lookup value is not found, so the IFERROR wrapper can be dispenced with. So the formula
=VLOOKUP("L0"&MID(G$4,1,1)&"A0"&MID(G$4,1,1)&MID(G$4,3,2)&"-0"&$B6,Sheet1!$C:$D,2,FALSE)
is sufficient as is.
To replace N/A results with error values, you can use this
Sub Demo()
Dim ws As Worksheet
Dim rngSrc As Range
Dim datV As Variant, datF As Variant
Dim i As Long
' Get range to process by any means you choose
' For example
Set ws = ActiveSheet
With ws
Set rngSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
' Copy data to variant arrays for efficiency
datV = rngSrc.Value
datF = rngSrc.Formula
' replace erroring formulas
For i = 1 To UBound(datV, 1)
If IsError(datV(i, 1)) Then
If datV(i, 1) = CVErr(xlErrNA) Then
datF(i, 1) = CVErr(xlErrNA)
End If
End If
Next
' return data from variant arrays to sheet
rngSrc.Formula = datF
End Sub
If you really want to use strings rather than true error values, adapt the If lines to suit

Rather than loop through all cells in a range, you can use SpecialCells to shorten working with the =NA()cells
This also open up a non-VBA method (if the only error cells are NA, ie no Div#/0)
The first two methods below (manual and code) deal with the situation where you only gave NA cells
the third uses SpecialCells to focus on only the cells that need to be tested, before then running a check for NA before making updates
option1
Manual selection of formula cells that evaluate to errors
Select the range of interest
Press [F5].
Click Special
Select Formulas
check only Errors
option2
VBA updating formula cells that evaluate to errors
code
Sub Shorter()
Dim rng1 As Range
On Error Resume Next
' All error formulas in column A
Set rng1 = Columns("A").SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'update with new value (could be value or formulae)
rng1.Value = "new value"
End Sub
option 3
Test for =NA()
Sub TestSpecificRegion()
Dim rng1 As Range
Dim rng2 As Range
Dim X
Dim lngRow As Long
On Error Resume Next
' All error formulas in column A
Set rng1 = Columns("A").SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'update with new value (could be value or formulae)
For Each rng2 In rng1.Areas
If rng2.Cells.Count > 1 Then
X = rng2.Value2
For lngRow = 1 To UBound(X, 1)
If X(lngRow, 1) = CVErr(xlErrNA) Then X(lngRow, 1) = "new value"
Next
rng2.Value = X
Else
If rng2.Value2 = CVErr(xlErrNA) Then rng2.Value = "new value"
End If
Next
End Sub

Related

VBA Excel run macro with IF AND THEN statement in sheet with ListObjects

I'm trying to run a macro with an IF AND THEN statement in a sheet with ListObjects.
In sheet "CommissionVoice" the macro has to check IF column "L" contains the text values "No Pay" or "Below Target". If it contains these strings then column K (an integer) needs to be calculated with column E (a percentage).
So far I was only able to create the next (Test) code with a simple IF statement but that didn't work:
Sub Test()
Dim tbl As ListObject
Dim rng As Range
Dim cel As Range
Set tbl = ActiveSheet.ListObjects("CommissionVoice")
Set rng = tbl.ListColumns(12).DataBodyRange
For Each cel In rng
If InStr(1, cel.Value, "No pay") > 0 Then
cel.Offset(0, -1).Value = "OK"
End If
Next cel
End Sub
Can someone help me with this?
Type mismatch errors can have different causes, for example you cannot assign a string to a number or a number to an object. Usually this error is easy to find using the debugger. Check all involved values/variables of the statement that raises the error.
In this specific case, the command InStr(1, cel.Value, "No pay") is raising the error. The only value that could be of wrong type is cel.Value which represents the value of an actual cell. Now a cell can hold only a numeric value, a string value, a boolean value or an error. Errors are not strings, they are a separate data type. When you see #N/A, this is not the String "#N/A". Those error values cannot be used as and not be converted into any other data type, and therefore you get the type mismatch error.
You can check for errors in VBA with the function IsError. So one could think that the statement should simply be changed into
If Not IsError(cel.Value) And InStr(1, cel.Value, "No pay") > 0 Then
however, that will not solve the issue - VBA will always check all parts of the condition and therefore the InStr-command would be executed anyhow.
2 attempts (there are other)
' 2 separate If-statements
If Not IsError(cel.Value) Then
If InStr(1, cel.Value, "No pay") > 0 Then
(...)
End If
End If
' Store the value into an intermediate variable and change an error to blank
Dim cellValue as Variant
cellValue = cel.Value
If IsError(cellValue) Then cellValue = ""
If InStr(1, cellValue, "No pay") > 0 Then
(...)
End If
But as already stated in the comments, it is likely it is better to solve this with a formula.
In an Excel Table (ListObject)
Sub Test()
' Reference the objects.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' adjust!
Dim lo As ListObject: Set lo = ws.ListObjects("CommissionVoice")
With lo
' Get the column indexes.
Dim colAdj As Long: colAdj = lo.ListColumns("Adjustments").Index
Dim colNps As Long: colNps = lo.ListColumns("NPS").Index
Dim colPer As Long: colPer = lo.ListColumns("NPS Performance").Index
With .DataBodyRange ' excluding headers
' Write the values from the data columns to arrays.
Dim adjData() As Variant: adjData = .Columns(colAdj).Value
Dim npsData() As Variant: npsData = .Columns(colNps).Value
Dim perData() As Variant: perData = .Columns(colPer).Value
Dim r As Long
' Loop over the rows and modify the values in the arrays.
For r = 1 To .Rows.Count
Select Case CStr(perData(r, 1))
Case "No pay", "Below Target"
' Maybe some rounding 'nps = Round(nps*(1-adj),2)' ?
npsData(r, 1) = npsData(r, 1) * (1 - adjData(r, 1))
perData(r, 1) = "OK"
'Case Else ' do nothing
End Select
Next
' Write the arrays back to their data columns.
.Columns(colNps).Value = npsData
.Columns(colPer).Value = perData
End With
End With
' Inform (don't know the jargon).
MsgBox "Negative commissions applied.", vbInformation
End Sub

Using for loops to identify rows

I tried here, here, and here.
I'm trying to highlight a row based on the string contents of a cell in the first column.
For example, if a cell in the first column contains the string "Total", then highlight the row a darker color.
Sub tryrow()
Dim Years
Dim rownum As String
Years = Array("2007", "2008", "2009") ' short example
For i = 0 To UBound(Years)
Set rownum = Range("A:A").Find(Years(i) & " Total", LookIn:=xlValues).Address
Range(rownum, Range(rownum).End(xlToRight)).Interior.ColorIndex = 1
Next i
End Sub
I get this error message:
Compile error: Object required
The editor highlights rownum = , as if this object hadn't been initialized with Dim rownum As String.
You've got a couple issues here, indicated below alongside the fix:
Sub tryrow()
Dim Years() As String 'Best practice is to dim all variables with types. This makes catching errors early much easier
Dim rownum As Range 'Find function returns a range, not a string
Years = Array("2007", "2008", "2009") ' short example
For i = 0 To UBound(Years)
Set rownum = Range("A:A").Find(Years(i) & " Total", LookIn:=xlValues) 'Return the actual range, not just the address of the range (which is a string)
If Not rownum Is Nothing Then 'Make sure an actual value was found
rownum.EntireRow.Interior.ColorIndex = 15 'Instead of trying to build row range, just use the built-in EntireRow function. Also, ColorIndex for gray is 15 (1 is black, which makes it unreadable)
End If
Next i
End Sub
You can avoid loop by using autofilter which will work much faster. The code assumes that table starts from A1 cell:
Sub HighlightRows()
Dim rng As Range, rngData As Range, rngVisible As Range
'//All table
Set rng = Range("A1").CurrentRegion
'//Table without header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=1, Criteria1:="*Total*"
'// Need error handling 'cause if there are no values, error will occur
On Error Resume Next
Set rngVisible = rngData.SpecialCells(xlCellTypeVisible)
If Err = 0 Then
rngVisible.EntireRow.Interior.ColorIndex = 1
End If
On Error GoTo 0
End Sub

How to get range data into VBA?

I am starting to learn VBA programming in Excel, so my question might be pretty basic.
All I am trying to do is:
1) Get my code to set some range (row or column)
2) Get my code to create an array with the values of that range
Imagine that I have some numbers in column A, from A1 to A50. If I select cell F7 (rng1 in the code below) and run the code, I would like to get the data A1:A7 (rng2), Z5 would give me A1:A5 and so on.
The first thing I tried was this:
Sub getdata()
Dim rng1 As Range 'This will be the selected cell
Dim rng2 As Range 'This will contain the data I want to retrieve
Dim data() As Variant 'And this will be the data
' Define the ranges
Set rng1 = Selection
Set rng2 = Range(Cells(1, 1), Cells(rng1.Row, 1))
'Get data
data = rng2.Value
Stop
End Sub
Which for some reason creates a tree structure instead of a one-dimensional array.
I would like to work comfortably with the data, so I looked and found a workaround on the Internet by means of this procedure:
Sub SubValuesFromRange()
Dim someRange As Range
Dim someValues As Variant
Set someRange = Selection
With someRange
If .Cells.Count = 1 Then
ReDim someValues(1 To 1)
someValues(1) = someRange.Value
ElseIf .Rows.Count = 1 Then
someValues = Application.Transpose(Application.Transpose(someRange.Value))
ElseIf .Columns.Count = 1 Then
someValues = Application.Transpose(someRange.Value)
Else
MsgBox "someRange is multi-dimensional"
End If
End With
Stop
End Sub
This procedure itself works fine. If I select A1:A5 and run it, it gets de data. If I try it with a row it works as well.
So I tried to create a function out of it, that I could use in my main procedure and that would be very useful for my future programms.
Here the code and the function:
Sub getdata()
Dim rng1 As Range 'This will be the selected cell
Dim rng2 As Range 'This will contain the data I want to retrieve
Dim data() As Variant 'And this will be the data
' Define the ranges
Set rng1 = Selection
Set rng2 = Range(Cells(1, 1), Cells(rng1.Row, 1))
'Get data, this time throug the function
data = ValuesFromRange(rng2)
Stop
End Sub
Function ValuesFromRange(someRange)
Dim someValues As Variant
With someRange
If .Cells.Count = 1 Then
ReDim someValues(1 To 1)
someValues(1) = someRange.Value
ElseIf .Rows.Count = 1 Then
someValues = Application.Transpose(Application.Transpose(someRange.Value))
ElseIf .Columns.Count = 1 Then
someValues = Application.Transpose(someRange.Value)
Else
MsgBox "someRange is multi-dimensional"
End If
End With
End Function
And... I get an error:
Number 13, type mismatch
Any idea why?
Is there may be a simpler way to get Excel data into VBA?

How to overcome the limit of hyperlinks in Excel?

I have a list of links in more than 100000 cells.
I have to give hyperlinks to all of them but in Excel there is a limit of 65530 hyperlinks per worksheet.
How can I overcome the limit or how can I merge cells with equal values using VBA?
Sub AddHyperlinks()
Dim myRange As Range
Set myRange = Range("A1")
Dim hText As Variant
Do Until IsEmpty(myRange)
hText = Application.VLookup(myRange.Value, Worksheets("Sheet2").Range("A:B"), 2, False)
If IsError(hText) Then
hText = ""
Else
ActiveSheet.Hyperlinks.Add Anchor:=myRange, Address:="http://" + hText, TextToDisplay:=myRange.Text
hText = ""
End If
Set myRange = myRange.Offset(1, 0)
Loop
End Sub
The solution is as mentioned by #Rory:
Use the HYPERLINK function in your cell to emulate a hyperlink via a formula.
=HYPERLINK(url, displaytext)
This effectively bypasses the built-in Excel limit on "hard-coded" hyperlinks. Just tested this out after I hit the infamous error 1004:
Application-defined or object-defined error
when trying to create 100k+ hyperlinks in a sheet.
Just regular copy paste should work, but I can update the example (not tested) if it doesn't
Sub AddHyperlinks()
Dim rng As Range, rngFrom As Range, values, r
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Set rngFrom = ThisWorkbook.Worksheets("Sheet2").Range("A:A")
rng.Worksheet.Hyperlinks.Delete ' remove all previous Hyperlinks
While rng(1) > ""
' resize the range to the same values
While rng(rng.Rows.Count + 1) = rng(1)
Set rng = rng.Resize(rng.Rows.Count + 1)
Wend
r = Application.Match(rng(1), rngFrom, 0)
If Not IsError(r) Then
values = rng.Value2 ' save the values
rngFrom(r, 2).Copy rng ' copy from the cell next to the match
rng.Value2 = values ' restore the values (not sure if it removes the links)
End If
Set rng = rng(rng.Rows.Count + 1) ' move to the next cell below
Wend
End Sub
If you store the URL in (eg) colA then something like this should work:
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim URL
If Target.Column <> 1 Then Exit Sub '<< only reacting if cell in URL column is right-clicked
URL = Target.Value
ThisWorkbook.FollowHyperlink URL
End Sub
Alternatively use the Before_DoubleClick event
It does mean you can't use a "friendly" link text such as "click here", but you could likely manage that if you store the URL text at a fixed offset and then read that instead of Target.Value
I suffered from the same problem and I know that I shouldn't have more than around 120000 rows that need hyperlinking so modified some code I found in another thread to this
Sub hyperlink2()
Dim Cell As Range
Dim Cell2 As Range
Dim rng As Range
Dim Rng2 As Range
Set rng = Range("X2:X60000")
For Each Cell In rng
If Cell <> "" Then ActiveSheet.Hyperlinks.Add Cell, Cell.Value
Next
Set Rng2 = Range("X60001:X120000")
For Each Cell2 In Rng2
If Cell2 <> "" Then ActiveSheet.Hyperlinks.Add Cell2, Cell2.Value
Next
End Sub
Hope that helps someone else who stumbles upon this via google (like I did) looking for a workable solution...
The 255 character limit applies to the limit of character that can be put in one cell's formula. A common approach to this is by splitting the link into multiple cells and using a formula to combine them.
=HYPERLINK(A1&A2,"Click Here")

Type Mismatch on Range For Loop

I am trying to rebuild a worksheet we use daily and in the process make it faster. I've been working with ranges now and trying to incorporate those but ran into a problem when trying to use UsedRange to get the last row for the range than finding it.
My code:
Sub RebuildAllFormat()
Dim SheetRNG As Range, RowDelete As Range, SOSheet As Worksheet
Set SOSheet = ThisWorkbook.Worksheets(Sheet1.Name)
Set SheetRNG = SOSheet.UsedRange.Columns(1)
For Each cell In SheetRNG
If cell.Value = "" Then
Cells(cell.Row, "P").Cut Cells(cell.Row - 1, "P")
If Not RowDelete Is Nothing Then
Set RowDelete = Union(RowDelete, cell)
Else
Set RowDelete = cell
End If
End If
Next cell
RowDelete.EntireRow.Delete
End Sub
The above code gives me the "Type Mismatch" error on If cell.Value = "" Then and it appears that the For loop no longer runs through each cell even though I get the expected value from Debug.Print SheetRNG.Address which is $A$1:$A$1736.
If I replace Set SheetRNG = SOSheet.UsedRange.Columns(1) with
lastrow = SOSheet.Cells(Rows.Count, "B").End(xlUp).Row
Set SheetRNG = SOSheet.Range(SOSheet.Range("A1"), SOSheet.Cells(lastrow, "A"))
then the loop works as expected and I'm able to check values. Running Debug.Print SheetRNG.Address after using the above also returns $A$1:$A$1736.
Am I missing something in the UsedRange code or is it not possible to use it that way?
As others have said, and you yourself identified, the issue is that For Each cell In SheetRNG returns the whole ranhe to cell.
Use For Each cell In SheetRNG.Cells to get each cell individually.
There are other issues in the code as well. See below comments for reccomendations
Sub RebuildAllFormat()
Dim SheetRNG As Range, RowDelete As Range, SOSheet As Worksheet
Dim cell as Range '<~~ Dim all variables
Set SOSheet = Sheet1 '<~~ Sheet1 is already a Worksheet reference
Set SheetRNG = SOSheet.UsedRange.Columns(1) '<~~ May overstate the required range, but will work OK
For Each cell In SheetRNG.Cells
If cell.Value = "" Then
'~~ Qualify the Sheet reference, otherwise it refers to the active sheet
With SOSheet
.Cells(cell.Row - 1, "P") = .Cells(cell.Row, "P") '<~~ faster than Cut/Paste
If Not RowDelete Is Nothing Then
Set RowDelete = Union(RowDelete, cell)
Else
Set RowDelete = cell
End If
End With
End If
Next cell
'~~ Avoid error if no blanks found
If Not RowDelete Is Nothing Then
RowDelete.EntireRow.Delete
End If
End Sub
The .Columns(1) statement does not that work the way you have used it. For example:
Set SheetRNG = Range("A1:B19").Columns(1)
is not the same like:
Set SheetRNG = Range("A1:A19")
You can .Resize() this .UsedRange.
Set SheetRNG = SOSheet.UsedRange.Resize(SOSheet.UsedRange.Rows.Count, 1)

Resources