I am trying to conditinally format every row that fails my IFERROR VLOOKUP formula in column A. I have gotten to where I can get the IFERROR cell to highlight, but not the entire now. Please help. This is what I have so far:
Range("A2:AH2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Not VA Student"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
It is unclear to me what you meant by your IFERROR VLOOKUP as i can't see this in your code.
I think you are wanting to only highlight rows where "Not VA Student" is found in the stipulated range. Your current code does this for individual cells.
I think the range selected is likely excessive in that you select to the bottom of the sheet within the specified column limits.
Try the following. I have made minor amendments to existing code, credits to user3598756
Private Sub HighlightRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell As Range
Dim rng As Range
Dim FirstFound As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") ' change as appropriate
Const fnd As String = "Not VA Student"
With ws.Range("A2:AH" & ws.Range("AH2").End(xlDown).Row) '<--| reference the range to search into ''#qharr: this seems excessive to me
Set FoundCell = .Find(what:=fnd, after:=.Cells(.Cells.Count)) '<--| find the first cell
If Not FoundCell Is Nothing Then 'Test to see if anything was found
FirstFound = FoundCell.Address ' <--| store the first found cell address
Set rng = FoundCell '<--| initialize the range collecting found cells. this to prevent first 'Union()' statement from failing due to 'rng' being 'Nothing'
Do
Set rng = Union(rng, FoundCell) 'Add found cell to rng range variable
'Find next cell with fnd value
Set FoundCell = .FindNext(after:=FoundCell)
Loop While FoundCell.Address <> FirstFound 'Loop until cycled through all finds
End If
End With
If Not rng Is Nothing Then rng.EntireRow.Interior.Color = 65535
End Sub
Related
I have 2 wb to_update_example_1 and purchasing_list
basically what I am trying to do is to a loop row by row on workbook to_update_example_1 if the same name is found to copy the a variable to the purchasing_list workbook.
However it keeps giving me error 91 at the searching portion and I would need an advice how do I write vVal2(which is the Qty) to Purchasing list workbook the column is just beside the found name so I tried to use active cell offset but didn't work too
any advice is appreciated thanks
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Integer
Dim vVal1, vVal2 As String
Numrows = Range("A1", Range("A1").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
Range("A1").Select ' Select cell a2.
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times.
vVal1 = Cells(x, 8)
vVal2 = Cells(x, 7)
Windows("Purchasing List.xls").Activate
ActiveSheet.Cells.Find(What:=vVal1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
''write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
Windows("To_update_example_1.xlsm").Activate
''''''''ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
When using the Find function, it's recommended if you set a Range object to the Find result, and also prepare your code for a scenario that Find didn't find vVal1 in "Purchasing List.xls" workbook. You can achieve it by using the following line If Not FindRng Is Nothing Then.
Note: avoid using Select, Activate and ActiveSheet, instead fully qualify all your Objects - see in my code below (with comments).
Modified Code
Option Explicit
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Long, Numrows As Long
Dim vVal1 As String, vVal2 As String
Dim PurchaseWb As Workbook
Dim ToUpdateWb As Workbook
Dim FindRng As Range
' set workbook object of "Purchasing List" excel workbook
Set PurchaseWb = Workbooks("Purchasing List.xls")
' set workbook object of "To_update_example_1" excel workbook
Set ToUpdateWb = Workbooks("To_update_example_1.xlsm")
With ToUpdateWb.Sheets("Sheet1") ' <-- I think you are trying to loop on "To_update_example_1.xlsm" file , '<-- change "Sheet1" to your sheet's name
' Set numrows = number of rows of data.
Numrows = .Range("A1").End(xlDown).Row
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times
vVal1 = .Cells(x, 8)
vVal2 = .Cells(x, 7)
' change "Sheet2" to your sheet's name in "Purchasing List.xls" file where you are looking for vVal1
Set FindRng = PurchaseWb.Sheets("Sheet2").Cells.Find(What:=vVal1, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
If Not FindRng Is Nothing Then '<-- make sure Find was successful finding vVal1
' write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
' Not sure eactly what you want to do now ???
Else ' raise some kind of notification
MsgBox "Unable to find " & vVal1, vbInformation
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Edited to account for OP's comment about where to search and write values
ShaiRado already told you where the flaw was
here's an alternative code
Option Explicit
Sub Macro1()
Dim cell As Range, FindRng As Range
Dim purchListSht As Worksheet
Set purchListSht = Workbooks("Purchasing List.xls").Worksheets("purchaseData") '(change "purchaseData" to your actual "purchase" sheet name)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Workbooks("to_update_example_1").Sheets("SourceData") ' reference your "source" worksheet in "source" workbook (change "SourceData" to your actual "source" sheet name)
For Each cell In .Range("H1", .Cells(.Rows.Count, 8).End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced "source" sheet column "H" not empty cells
Set FindRng = purchListSht.Columns("G").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns) ' try finding current cell content in "purchase" sheet column "G"
If Not FindRng Is Nothing Then FindRng.Offset(, -2).Value = cell.Offset(, -1).Value ' if successful, write the value of the cell one column left of the current cell to the cell two columns to the left of found cell
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Good day, I am newbie in VBA programming. need some help from experts :)
After i enter the date and click the generate button the code will find the date on the excel, but im done with this problem and here are my codes..
Dim Rng As Range
Dim FindDate As Date
FindDate = txtDate.Value
If Trim(FindDate) <> "" Then
With Sheets("Sheet2").Range("B:B")
Set Rng = .Find(What:=FindDate, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
My next problem is, i need to select the empty cell next to the date.. Here is a screen shot
To answer your specific question, the simplest way would be:
Rng.Offset(, 1).Select
However, you ought to be aware that the Find() function when using dates can be a little unreliable. See this post for more info and links: VBA, goto cell with a certain value (type: date). Your case is particularly exposed to risk as the date is entered via a TextBox.
I have to say your code looks awfully similar to the OP's of that post. You really ought to credit code sources if you didn't write it yourself.
If I were you, I'd convert your textbox value to a Long and then search the cell values (using the .Value2 property which provides date values as Longs) for the matching Long. Code isn't much longer and could look like this:
Dim src As Range
Dim findDate As Date
Dim findVal As Long
Dim cell As Range
'Define the source data range
With Sheet2
Set src = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp))
End With
'Acquire search date and convert to long
findDate = CDate(UserForm1.txtDate.Value)
findVal = CLng(findDate)
'Search for date
For Each cell In src.Cells
If cell.Value2 = findVal Then
Application.Goto cell, True
'Select the next cell to the right
cell.Offset(, 1).Select
End If
Next
you could
use a Function to try returning the wanted range
Function SetRange(FindDate As Date) As Range
If Trim(FindDate) <> "" And IsDate(FindDate) Then
With Sheets("Sheet2") '<--| reference wanted sheet
With .Range("B1", .cells(.Rows.Count, 2).End(xlUp)) '<--| reference its column "B" range from row 1 down to last not empty row
On Error Resume Next '<--| if subsequent 'Find()' avoid possible subsequent statement error to stop the Function
Set SetRange = .Find(What:=FindDate, After:=.cells(.cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Offset(, 1) '<--| try finding the passed 'FindDate' in referenced range and offset 1 column to the right
End With
End With
End If
End Function
and have your "Main" sub check it against Nothing before using it:
Option Explicit
Sub Main()
Dim Rng As Range
Set Rng = SetRange(txtDate.Text)
If Not Rng Is Nothing Then Rng.Select
End Sub
I am quite new to VBA, I have attempted to write a code below, but I'm getting a type mismatch error (Highlighted below). What I am trying to achieve is the following:
I have a list of properties on column A (all hyperlinked to their own respective sheets) on the first summary sheet called "sheet"
For each property, go to that properties sheet
Copy the value 3 cell right to the cell with the string "Total for this Property"
Switch back to "sheet" and paste the value into column D, next to the corresponding property name in column A.
I think the issue is the way I am referencing the value in the other sheet, but I can't seem to find anywhere how to reference a value that is located somewhere relative to a cell with a specific text.
Thank you in advanced!
Sub Summary()
Dim MasterBook As Workbook
Dim Sht As Worksheet
Dim Rng, Rng2 As Range
Set MasterBook = ThisWorkbook
Set Sht = MasterBook.Worksheets("Sheet")
Set Rng = Sht.Range("A6:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)
Dim Cell As Range
For Each Cell In Rng
Cell.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Cell.Offset(0, 3).Value = Cell.Value("Total for this Property").Offset(0, 3).Value '<---- This line is giving the error
Next Cell
End Sub
Try this
Sub Summary()
Dim MasterBook As Workbook
Dim Sht As Worksheet
Dim Rng As Range, Rng2 As Range, Rng3 As Range
Set MasterBook = ThisWorkbook
Set Sht = MasterBook.Worksheets("Sheet")
Set Rng = Sht.Range("A6:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)
Dim Cell As Range
For Each Cell In Rng
Set Rng3 = MasterBook.Sheets(Cell.Text).Cells.Find(What:="Total for this Property", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not Rng3 Is Nothing Then
Cell.Offset(0, 3).Value = Rng3.Offset(, 3).Value
Else
MsgBox "not found"
End If
Next Cell
End Sub
It's no wonder that this line is giving you trouble:
Cell.Offset(0, 3).Value = Cell.Value("Total for this Property").Offset(0, 3).Value
The Value property doesn't take arguments like this! I assume you are trying the find the cell with the text Total for this Property and offset 3 from it?
In that case you should look into the Find command.
Dim myFoundCell as Range
Set myFoundCell = ActiveWorkbook.ActiveSheet.UsedRange.Find(what:="Total for this Property", lookat:=xlWhole)
If Not myFoundCell Is Nothing Then
Cell.Offset(0, 3).Value = myFoundCell.Offset(0,3).Value
End If
I think you'll also have trouble handling which workbook you're in (the ActiveWorkbook) after following a load of hyperlinks, so look into ActiveWorkbook and ThisWorkbook. What I mean is, that each range must be within a sheet on a given workbook. You're trying to copy across workbooks so will have to specify where data is going to / coming from.
Docs for Find: https://msdn.microsoft.com/en-us/library/office/ff839746.aspx
Another question when you get stuck perhaps.
I guess you're after this:
Sub Summary()
Dim Cell As Range, foundCell As Range
With ThisWorkbook.Worksheets("Sheet")
For Each Cell In .Range("A6", .Cells(.Rows.count, "A").End(xlUp))
Cell.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Set foundCell = ActiveSheet.UsedRange.Find(what:="Total for this Property", lookat:=xlWhole, LookIn:=xlValues)
If Not foundCell Is Nothing Then Cell.Offset(0, 3).Value = foundCell.Offset(0, 3).Value '<---- This line is giving the error
Next Cell
.Activate
End With
End Sub
Since you want to "fetch" the value from a certail Worksheet (which name is placed in the cell) and not in the entire Workbook, you need to use the Find for that specific Worksheet.
The Find method syntax for that is :
Set FindRng = Worksheets(Cell.Value).Cells.Find("Total for this property")
Sub-loop Code:
Dim Cell As Range, FindRng As Range
For Each Cell In Rng
Cell.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Set FindRng = Worksheets(Cell.Value).Cells.Find("Total for this property")
If Not FindRng Is Nothing Then ' verify that Find was successful
Cell.Offset(0, 3).Value = FindRng.Offset(0, 3).Value
End If
Next Cell
I hope you can help. I have a some code below which works fine. What it does is opens up a dialog box allows a user to select an excel file, once this file is selected.
The code looks through the column headings find the Text "CountryCode" then cuts this column puts it into Column F then separates column F into new worksheets based on the country.
This issue I am facing is that sometimes the the column I want to cut contains the text "ClientField10" or "ClientField1"
So what I would like the macro to do is search the column headings for "CountryCode" if this is found fine execute the rest of the code.
If it is NOT found search for "CleintField10" then if found execute and if neither "CountyCode" or "CleintField10" is found search for "CleintField1" then execute the rest of the code
My code is below as always any help is greatly appreciated.
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
Dim my_Workbook As Workbook
MsgBox "Pick your TOV file" '<--| txt box for prompt to pick a file
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection
If my_FileName <> False Then
Set my_Workbook = Workbooks.Open(Filename:=my_FileName)
Call Sample(my_Workbook) '<--|Calls the Filter Code and executes
Call Filter(my_Workbook) '<--|Calls the Filter Code and executes
End If
End Sub
Public Sub Sample(my_Workbook As Workbook)
Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
'~~> Change this to the relevant sheet
Set ws = my_Workbook.Sheets(1)
With ws
Set aCell = .Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
'~~> If Found
If Not aCell Is Nothing Then
'~~> Cut the entire column
aCell.EntireColumn.Cut
'~~> Insert the column here
Columns("F:F").Insert Shift:=xlToRight
Else
MsgBox "Country Not Found"
End If
End With
End Sub
Public Sub Filter(my_Workbook As Workbook)
Dim rCountry As Range, helpCol As Range
With my_Workbook.Sheets(1) '<--| refer to data worksheet
With .UsedRange
Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
End With
With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A"
.Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 6th column of the referenced range and store its unique values in "helper" column
Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
.AutoFilter 6, rCountry.Value2 '<--| filter data on country field (6th column) with current unique country name
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet
ActiveSheet.Name = rCountry.Value2 '<--... rename it
.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
End If
Next
End With
.AutoFilterMode = False '<--| remove autofilter and show all rows back
End With
helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub
Because I didn't get to test my code before, I made the silly mistake of using "If" instead of an "ElseIf" statements. I tested the below code and now it works.
Sub test()
Dim acell As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1) 'define ws
Set acell = ws.Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False) 'define acell as location of "countrycode"
If Not acell Is Nothing Then 'if address is found do the cut & insert of that column
acell.EntireColumn.Cut
Columns("F:F").Insert Shift:=xlToRight
ElseIf acell Is Nothing Then 'if address is not found redefine acell to look for "clientfield10"
Set acell = ws.Range("A1:BB50").Find(What:="ClientField10", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not acell Is Nothing Then 'if address is found do the cut & insert
acell.EntireColumn.Cut
Columns("F:F").Insert Shift:=xlToRight
ElseIf acell Is Nothing Then 'If not found redefine acell again to look for "ClientField1"
Set acell = ws.Range("A1:BB50").Find(What:="ClientField1", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not acell Is Nothing Then 'If found do cut and insert
acell.EntireColumn.Cut
Columns("F:F").Insert Shift:=xlToRight
Else: MsgBox "Country Not Found" 'If none can be found display msgbox
End If
End If
End If 'close all the If loops
End Sub
I will delete my old answer to make this thread easier to understand
I have a worksheet (Sheet2) that contains 27 columns, first row is the columns headers which are A-Z and NUM totaling 27 cols. Each column has a very long list of restricted urls sorted to the letter of the column, and the last (27th) column is for urls that start with a number. The columns' length is between 300-600 thousand cells.
What I have been looking for was a macro script that will examine all newly added urls in col A Sheet1, to find out whether they exist in Sheet2, resulting in flagging each url with "already exist" or "to be added", something like:
Sheet1
Col(A) Col(B)
badsite1.com already exist
badsite2.com already exist
badsite3.com to be added
badsite4.con to be added
badsite5.com already exist
Accordingly "to be added" urls will be added to Sheet2 after running another test online for that url.
Amazingly, I found the following script (missed its source) that does exactly what I'm after applying some minor modifications:
Sub x()
Dim rFind As Range, sFind As Range, sAddr As String, ws As Worksheet, rng As Range, ms As Worksheet
Application.ScreenUpdating = 0
Set ws = Sheets("Sheet2")
Set ms = Sheets("Sheet1")
ms.Range("B2:B" & Rows.Count).ClearContents
Set rng = ms.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each sFind In rng
With ws.UsedRange
Set rFind = .Find(sFind, .Cells(.Cells.Count), xlValues, xlPart)
If Not rFind Is Nothing Then
sAddr = rFind.Address
Do
sFind.Offset(, 1) = rFind.Address
sFind.Font.Color = -16776961
Set rFind = .FindNext(rFind)
Loop While rFind.Address <> sAddr
sAddr = ""
Else
sFind.Offset(, 1) = "No Found"
sFind.Offset(, 1).Font.Color = -16776961
End If
End With
Next
Set ms = Nothing
Set ws = Nothing
Set rng = Nothing
Set rFind = Nothing
Application.ScreenUpdating = True
End Sub
Running this script is fantastic with a small list of urls (e.g 5-10). With a longer list in Sheet1 col-A and HUGE lists in Sheet2 like mine, this script is a "tortoise", and it took over one hour to examine a list of 167 urls!!
Can this script be modified to be a "rabbit"? :)
Highly appreciating any offered assistance in this regard.
As usual.. thanks in advance.
Try this - Tested in Excel 2010:
Sub x()
Dim rFind As Range, sFind As Range, sAddr As String, ws As Worksheet
Dim rng As Range, ms As Worksheet, s As String
Application.ScreenUpdating = False
'stop calculation
Application.Calculation = xlCalculationManual
Set ws = Sheets("Sheet2")
Set ms = Sheets("Sheet1")
ms.Range("B2:B" & ms.Rows.Count).ClearContents
ms.Range("A2:B" & ms.Rows.Count).Font.Color = 0
Set rng = ms.Range("A2:A" & ms.Cells(ms.Rows.Count, 1).End(xlUp).Row)
For Each sFind In rng
'get first character of url
s = Left(sFind, 1)
'resort to column aa if not a a to z
If Asc(UCase(s)) < 65 Or Asc(UCase(s)) > 90 Then s = "AA"
'only look in appropriate column
Set rFind = ws.Columns(s).Find(sFind, , xlValues, xlPart, xlByRows, xlPrevious)
If Not rFind Is Nothing Then
'only look once and save that cell ref
sFind.Offset(, 1) = rFind.Address
sFind.Font.Color = -16776961
Else
'if not found put default string
sFind.Offset(, 1) = "No Found"
sFind.Offset(, 1).Font.Color = -16776961
End If
Next
Set ms = Nothing
Set ws = Nothing
Set rng = Nothing
Set rFind = Nothing
'enable calculation
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Non VBA - Tested on Excel 2010:
=IFERROR(VLOOKUP(A2, INDIRECT("Sheet2!" & IF(OR(CODE(UPPER(LEFT(A2, 1)))<65,
CODE(UPPER(LEFT(A2, 1)))>90), "AA:AA", LEFT(A2, 1)&":"& LEFT(A2, 1))), 1, FALSE),
"Not Found")