I am tring to alter this code FindReplace_With_Offset_1 to FindReplace_With_Offset_2
FindReplace_With_Offset_1 Run on a Col Range and it works fine
I need FindReplace_With_Offset_2 to run only on each Cell in the Col Range i.e. I need each cell to be its own range, when I run it I get #NAME? for every Cell with value #N/A
Thanks
Sub FindReplace_With_Offset_1()
Dim wsFR As Worksheet, wsT As Worksheet
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
With .Range("B2:B" & tLR) 'The Offset Range
.Value = _
"=VLOOKUP(D2," & wsFR.Range("D1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
.Value = .Value
End With
End With
End Sub
Code2
Sub FindReplace_With_Offset_2()
Dim wsFR As Worksheet, wsT As Worksheet
Dim Rng As Range, aCell As Range
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
Set Rng = .Range("A2:A" & tLR)
For Each aCell In Rng
If aCell.text = "#N/A" Then
aCell.Value = _
"=VLOOKUP(aCell," & wsFR.Range("C1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
aCell.Value = aCell.Value
Else
aCell = aCell
End If
Next aCell
End With
End Sub
Maybe it's because you're trying to put the code to read a error value, and for the excel the cell value isn't the text "#N/A", try to use the IfError formula to run the verification on the desired cell, like this:
If WorksheetFunction.IfError(aCell,"Error") = "Error" Then
Related
How to autosum column using column header in vba code? I am trying to autosum few columns in excel sheet but column position is changing every time.
Dim Rng As Range
Dim c As Range
Set Rng = Range("F1:F" & Range("F1").End(xlDown).Row)
Set c = Range("F1").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"
Set Rng = Range("G1:G" & Range("G1").End(xlDown).Row)
Set c = Range("G1").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"
Set Rng = Range("H1:H" & Range("H1").End(xlDown).Row)
Set c = Range("H1").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"
Find Headers to Insert Autosum (Application.Match)
It is assumed that the headers are in the first row of the worksheet's used range.
Sub InsertAutosum()
Dim Headers(): Headers = Array("Sales 2020", "Sales 2021", "Sales 2022")
Dim ws As Worksheet: Set ws = ActiveSheet
Dim trg As Range ' Table Range
With ws.UsedRange
Dim lCell As Range
Set lCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub
Set trg = .Resize(lCell.Row - .Row + 1)
End With
Dim hrg As Range: Set hrg = trg.Rows(1) ' Header Range
Dim trCount As Long: trCount = trg.Rows.Count
Dim srg As Range: Set srg = trg.Resize(trCount - 1).Offset(1) ' Sum Range
Dim Header, cIndex, sFormula As String
For Each Header In Headers
cIndex = Application.Match(Header, hrg, 0)
If IsNumeric(cIndex) Then
sFormula = "=SUM(" & srg.Columns(cIndex).Address(, 0) & ")"
hrg.Offset(trCount).Cells(cIndex).Formula = sFormula
End If
Next Header
End Sub
how to autosum column using column header in vba code
If you know the column header, then it becomes very easy. Here is an example. Let's say the header of the column is SOME-HEADER and we are not sure which column it is in but the headers are in row 1. If they are not in row 1 then you will have to tweak the code accordingly.
I have commented the code but if you still have a question then simply ask.
Option Explicit
Sub Sample()
Dim Ws As Worksheet
Dim HeaderText As String
Dim HeaderRow As Long
Dim HeaderColumn As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
Dim i As Long
'~~> Change this to the relevant worksheet
Set Ws = Sheet1
'~~> Column Header text. Change as applicable
HeaderText = "SOME-HEADER"
'~~> Headers are in row 1. Change as applicable
HeaderRow = 1
With Ws
'~~> Check if there is data in the worksheet
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "There is no data in thw worksheet"
Exit Sub
End If
'~~> Find last column
LastColumn = .Cells(HeaderRow, .Columns.Count).End(xlToLeft).Column
'~~> We can use .Find to find the header row but it may be an overkill
'~~> So we use a simple loop
For i = 1 To LastColumn
'~~> Checking for an exact match.
If UCase(Trim(.Cells(HeaderRow, i).Value)) = UCase(Trim(HeaderText)) Then
HeaderColumn = i
Exit For
End If
Next i
'~~> Check if we found the column
If HeaderColumn = 0 Then
MsgBox "Unable to find the column"
Exit Sub
End If
'~~> Find the last row in the column
LastRow = .Cells(.Rows.Count, HeaderColumn).End(xlUp).Row
'~~> This is the range
Set rng = .Range(.Cells(2, HeaderColumn), .Cells(LastRow, HeaderColumn))
'~~> Insert Sum Formula
.Cells(LastRow + 1, HeaderColumn).Formula = "=Sum(" & _
rng.Address(False, False) & _
")"
End With
End Sub
SCREENSHOT
I have an excel sheet in which folder path are mentioned in the cells of Column C, I need to create hyperlinks to each cell in Column C so that if I click on it then it will dirent me to that folder for which the path is mentioned in the cell
Sub folderpathyperlink ()
Dim sfolder As String
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet2")
bottomA = sh.Range("I" & Rows.Count).End(xlUp).Row
sfolder = Cells(2, bottomA).Value
For Each cell In sfolder
ThisWorkbook.Sheets("Sheet2").Hyperlinks.Add anchor:=Selection, Address:=sfolder
Next cell
End Sub
Try something like this...
Sub folderpathyperlink()
Dim sh As Worksheet
Dim lr As Long
Dim Rng As Range, Cell As Range
Set sh = ThisWorkbook.Sheets("Sheet2")
lr = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
Set Rng = sh.Range("C2:C" & lr)
For Each Cell In Rng
sh.Hyperlinks.Add Anchor:=Cell, Address:= _
Cell.Value, TextToDisplay:=Cell.Value
Next Cell
End Sub
To check if a cell in column C contains a valid folder path and if that folder exists, insert the hyperlink otherwise skip the code, try the below code...
Sub folderpathyperlink()
Dim sh As Worksheet
Dim lr As Long
Dim Rng As Range, Cell As Range
Set sh = ThisWorkbook.Sheets("Sheet2")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
Set Rng = sh.Range("C2:C" & lr)
For Each Cell In Rng
If Not Dir(Cell.Value, vbDirectory) = "" Then
sh.Hyperlinks.Add Anchor:=Cell, Address:= _
Cell.Value, TextToDisplay:=Cell.Value
End If
Next Cell
End Sub
I can't evaluate the sumproduct at the end of the code. I think everything else is working but I keep getting the
Type Mismatch Error
I've tried all sorts of variations of syntax and I still can't get it to work. Any ideas?
Sub Sample()
Dim ws As Worksheet
Dim x As Long
Dim lRow As Long, llRow As Long
Dim aCell As Range, bCell As Range
Dim rng1 As Range, rng2 As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set aCell = .Range("B6:E20").Find(Cells(14, 9).Offset(0, -1).Value)
If Not aCell Is Nothing Then
lRow = .Range(Split(.Cells(, aCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row
If lRow > 1 Then
Set rng1 = .Range(aCell.Offset(1), .Cells(lRow, aCell.Column))
End If
End If
Set bCell = .Range("B6:E20").Find(Cells(14, 9).Offset(-1, 0).Value)
If Not bCell Is Nothing Then
llRow = .Range(Split(.Cells(, bCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row
If llRow > 1 Then
Set rng2 = .Range(bCell.Offset(1), .Cells(lRow, bCell.Column))
End If
End If
Debug.Print rng1.Address
Debug.Print rng2.Address
x = Evaluate("=sumproduct(""rng1"",""rng2"")")
End With
End Sub
rng1 and rng2 doesn't mean anything to Sumproduct function as it is not a Named Range or a valid range address. And so Evaluate function fails.
To make it work try:
x = Evaluate("=sumproduct(" & rng1.Address & "," & rng2.Address & ")")
Now to make sure that you evaluate your correct ranges, you might want to set the External argument of Address property to True.
x = Evaluate("=Sumproduct(" & rng1.Address(, , , True) & _
"," & rng2.Address(, , , True) & ")")
In excel 2010, how to do a validation if cell contain ',' then pop up a message to user ?
Please try to show your work ..
lets say Column A contains the data then below code work perfectly
this is what u wanted (TESTED)
Sub tested()
Dim erange As Range
Dim lrow As Integer
lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For Each erange In Range("A2:A" & lrow)
If InStr(erange.Value, ",") > 0 Then
MsgBox (erange.Address & " contains Comma ")
erange.Interior.Color = vbRed
End If
Next erange
End Sub
Using normal data validation, you could try this
=(LEN(A1) = LEN(SUBSTITUTE(A1,",","")))
If you want to avoid unnecessary loop use below code.
Sub findComma()
Dim srcRng As Range, findRng As Range
Dim firstCell As String
Dim lrow As Integer
lrow = Range("A" & Rows.Count).End(xlUp).Row
Set srcRng = Range("A1:A" & lrow)
Set findRng = srcRng.Find(What:=",", LookIn:=xlValues, LookAt:=xlPart)
If Not findRng Is Nothing Then firstCell = findRng.Address
Do Until findRng Is Nothing
MsgBox (findRng.Address & " contains Comma ")
findRng.Interior.Color = vbRed
Set findRng = srcRng.FindNext(findRng)
If findRng.Address = firstCell Then Exit Sub
Loop
End Sub
I have a bunch of column of rows that contain text such as:
dog,cat,mouse
bat,dog,fly
fish,beaver,horse
I'm trying to search and highlight rows that contain certain word:
Public Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Dim LR As Long
Dim vVal
Dim tRow
LR = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B1:B" & LR)
iWarnColor = xlThemeColorAccent2
For Each rngCell In rng.Cells
tRow = rngCell.Row
If InStr(rngCell.Value, "dog") = 1 Then
rngCell.Interior.ColorIndex = iWarnColor
Else
rngCell.Interior.Pattern = xlNone
End If
Next
End Sub
This works fine so long as the word 'dog' is the first word in the comma string, so it would highlight the first row but not row two because the word 'dog' appears after 'bat'. Do I need to strip the commas out first or is there a better way of doing this?
It looks like your ultimate goal is to color the row based on whether or not 'dog' is in a cell. Here's a different way to do it that doesn't even involve VBA (this example assumes your data is all in column A):
Make a new column to the right. Use the formula =IF(NOT(ISERROR(FIND("dog",A1))),1,0). You can hide the column later so the user doesn't see it. Basically, if it has the word 'dog' somewhere, then return 1 else 0.
Select the entire first row
Under Conditional Formatting, go to New Rule
Choose Use a Formula
For your formula, try =$B2=1
Now that you've conditionally colored one row, copy and paste format to the other rows.
All rows should now update automatically.
Extra Credit: If this data is formatted as a table object, the conditional formatting should automatically carry over to new rows as they are added.
Further to my comments above
Example 1 (Using .Find and .Findnext)
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range, bCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
rng.Interior.ColorIndex = xlNone
Set aCell = rng.Find(What:="dog", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = iWarnColor
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = iWarnColor
Else
Exit Do
End If
Loop
End If
End With
End Sub
Screenshot
Example 2 (Using Autofilter)
For this ensure that there is a Heading in Cell B1
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
'~~> Remove any filters
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
With rng
.AutoFilter Field:=1, Criteria1:="=*dog*"
Set aCell = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
If Not aCell Is Nothing Then aCell.Interior.ColorIndex = iWarnColor
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub