I would like a code to check every cell in range A1:A14 and if the cell is highlighted say yes or no in column B.
.
Sub highlighted()
Dim rng As Range
Dim c As Range
Set rng = ActiveCell
For Each c In rng
If c.Interior.Pattern <> xlNone Then
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "Yes"
Exit Sub
End If
Next c
End Sub
This code works sucsessfully for one single highlighted cell, how can I get it to loop through my desired range, and also include the "no" for non-highlighted cells?
Thanks In Advance!
This would be the code. Read the comments and adjust according your needs.
Sub highlighted()
Dim evaluatedRange As Range
Dim evaluatedCell As Range
Dim sheetName As String
Dim rangeAddress As String
' Adjust these two parameters
sheetName = "Sheet1" ' Sheet name where the range is located
rangeAddress = "A1:A14"
Set evaluatedRange = ThisWorkbook.Worksheets(sheetName).Range(rangeAddress)
' This will loop through each cell in the range
For Each evaluatedCell In evaluatedRange
' Evaluates if the cell has a pattern (what ever it is)
If evaluatedCell.Interior.Pattern <> xlNone Then
' Set the value of the cell next to the one evaluated (same row - rowOffset:=0 but next column columnOffset:=1) to Yes
evaluatedCell.Offset(rowOffset:=0, columnOffset:=1).Value = "Yes"
' Exit Sub -> This would exit the whole process, so if you want to evaluate the whole range, just delete this line
Else
evaluatedCell.Offset(rowOffset:=0, columnOffset:=1).Value = "No"
End If
Next evaluatedCell
MsgBox "Process finished!" ' -> alert the user...
End Sub
If this is what you need, remember to mark the answer to help others.
If I understand what you are trying to do, you could simply do:
Sub highlighted()
Dim rng As Range
Dim c As Range
Set rng = Range("A1:A14")
For Each c In rng
If c.Interior.Pattern <> xlNone Then
c.Range("A1").Offset(0,1).Value = "Yes"
End If
Next c
End Sub
See How to avoid using Select in Excel VBA for tips on avoiding unneeded Selects
Related
I'm trying to build a VBA application that checks for a certain value, then adds a row on top for each time this value is found.
Sub copy()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("B2:B10")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.value = "test" Then
MsgBox "found" + cell.Address
cell.EntireRow.Insert
End If
Next cell
Next row
End Sub
Every time I try to run this function, however, it keeps adding rows on top of each other continuously and not for each occurrence.
If you loop the cells from top to bottom, adding the row will push your original range down, causing the next loop to evaluate the previous cell.
To avoid this, loop backwards (i.e. bottom to top):
Sub copy_test()
Dim rng As Range
Set rng = Range("B2:B10")
Dim i As Long
For i = rng.Cells.Count To 1 Step -1
If rng.Cells(i).Value = "test" Then
Debug.Print "Found"
rng.Cells(i).EntireRow.Insert
End If
Next i
End Sub
Note: Set rng = Range("B2:B10") is telling VBA that you are referring to Cells B2:B10 of the ActiveSheet which might not be what you want.
Please fully qualify your range to avoid this. (e.g. ThisWorkBook.Worksheets("Sheet1").Range("B2:B10") or use the code name of the worksheet Sheet1.Range("B2:B10").)
I'm close to what i want to do but not sure if I'll have to change method completely to get this done.
The below code works almost completely. I want to find all empty cells in range: C2:C120 and enter a formula from another worksheet: Worksheets("Sheet2").Range("F57").
It finds empty cells but it copies the text in the F57 cell, which is #N/A at the moment, not the formula. The formula is =VLOOKUP(D57,'[Example.xlsx]Sheet1'!$A$2:$D$37,2) but I can't enter it directly into the code as it will always look for D57, not dynamically.
Any help is hugely appreciated, hopefully it's a simple fix.
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim rng As Range
Set ws = Worksheets("Sheet1")
For Each rng In ws.Range("C2:C120")
If IsEmpty(rng) Then
rng.Formula = Worksheets("Sheet2").Range("F57")
End If
Next
End Sub
I couldn't find an answer for this specifically though I'm sure i've come accross one before.
If I understand correctly, the following should work.
In your loop you can reference the rng row number in your formula.
You could use (note, not tested):
For Each rng In ws.Range("C2:C120")
If IsEmpty(rng) Then
rng.Formula = "=VLOOKUP(D" & rng.Row & ",'[Example.xlsx]Sheet1'!$A$2:$D$37,2)"
End If
Next rng
This uses the Row property of the Range object, which is the row number of whatever cell you are accessing in your loop in each iteration, and uses it as the row number for your D57 part of your formula (per your posted formula).
Update Data From Different Workbook
Adjust the constants in updateCustomers.
The Code
Sheet1 (or wherever you have CommandButton3)
Option Explicit
Private Sub CommandButton3_Click()
updateCustomers
End Sub
Module1
Sub updateCustomers()
' Source
Const wbsName As String = "Example.xlsx"
Const srcName As String = "Sheet1"
Const srcAddr As String = "A2:B37"
' Target
Const tgtName As String = "Sheet1"
Const LookupCol As String = "A"
Const tgtAddr As String = "C2:C120"
' Ranges
Dim src As Range
Set src = Workbooks(wbsName).Worksheets(srcName).Range(srcAddr)
Dim tgt As Range
Set tgt = ThisWorkbook.Worksheets(tgtName).Range(tgtAddr)
' The Loop
Dim cel As Range
For Each cel In tgt.Cells
If IsEmpty(cel) Then
On Error Resume Next
cel.Value = WorksheetFunction _
.VLookup(tgt.Parent.Cells(cel.Row, LookupCol).Value, src, 2, False)
On Error GoTo 0
End If
Next
MsgBox "Customers updated.", vbInformation, "Success"
End Sub
I want to look through a table in a sheet. Find each cell with "Yes" in it, when one is found. Paste a Yes to A1, when another is found A2, etc...
I was trying to modify this code to search all cells instead of just Row A
Following code should give you the headstart
Sub Text_search()
Dim Myrange As Range
Set Myrange = ActiveSheet.UsedRange
For Each cell In Myrange
If InStr(1, cell.Value, "YES") > 0 Then
'do something
Else
'do something else
End If
Next
End Sub
Further to #isomericharsh's answer, if it's a table you're looking through, that simplifies defining the range; just use DataBodyRange.
If the table 'Table1' is on 'Sheet1' and the results are to be posted on 'Sheet2' then I'd do as follows:
Sub Search_for_Yes()
Dim YesAmt As Long ' - Amount of yes's found
YesAmt = 0 'to start with
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = Sheets("Sheet2")
'It's always safer to use specific references rather than ActiveSheet
For Each cell In ws1.ListObjects("Table1").DataBodyRange 'The data in the table excluding headings and totals
If cell.Value = "YES" Then 'might need to add wildcards to this if you want to include cells that contain yes as part of larger text string. Also note that it's case-specific.
ws2.Cells(1 + YesAmt, 1).Value = "Yes" 'so that each time a yes is found it will log it further down
YesAmt = YesAmt + 1
End If
Next
x = MsgBox(YesAmt & " values found and listed", vbOKOnly + vbInformation)
End Sub
Does that help?
I would like to determine if a cell in my range contains a date (any date) and if it does to exit the sub with a message.
The date format looks like this: dd-mmm-yy but is generated by a formula within the cell.
Here is some of my code already written along with some pseudo code of what I want to achieve.
Sub RemoveRowButton()
'This Macro deletes a row where the button is clicked.
'Variables
Dim row As Long
Dim varResponse As Variant
Application.ScreenUpdating = False
'Message box confirming user is doing the right thing
varResponse = MsgBox("Delete this row? 'Yes' or 'No'", vbYesNo, "Delete Row")
If varResponse <> vbYes Then Exit Sub
'Carry on with deleting row.....
Set rng = ActiveSheet.Buttons(Application.Caller).TopLeftCell.EntireRow
*******Pseudo Code *******
'Check if the row to be deleted has a date in the D Column of the range (which is a Row)
'If IsDate **in D column of the Range is ture*** Then
'MsgBox "This Row Contains a Date!"
'End If
'Unprotect sheet
ActiveSheet.Unprotect Password:="***"
'Delete row on button row
rng.Delete
'Protect sheet again
ActiveSheet.Protect Password:="***"
End Sub
If you could explain your code/answers too I would be grateful, Thanks.
EDIT:
Thank you for all the help, I have, through trial and error created this which works for me.
Set rng2 = rng.Cells(, 4)
If IsDate(rng2.Value) Then 'Check Cell for Date
MsgBox "Warning: This Row Cannot be deleted!"
Exit Sub
End If
Since I am unfamiliar with VBA I do not know if this is "OKAY" in the sense of best practices. If not and you feel like correcting it please do so.
Here is an idea for your problem. Install the code in the code sheet of the worksheet on which you wish to have the action (not in a standard module like 'Module1' !!) Note that the code reacts to a double-click in column D from row 2 down to the last used row in column A. You can adjust that. Follow the directions in the code itself. I use this method instead of the button you seem to have in every row of your sheet - a matter of preference, but used here for demonstration and to avoid creating buttons.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' 03 Jan 2019
Dim Rng As Range
Dim R As Long
Dim Cell As Range
Dim i As Integer
R = Cells(Rows.Count, "A").End(xlUp).Row ' last used row in column A
Set Rng = Range(Cells(2, 4), Cells(R, 4)) ' used range in column D
If Not Application.Intersect(Target, Rng) Is Nothing Then
' if a cell in Rng as double-clicked:-
R = Target.Row
Set Rng = Range(Cells(R, "A"), Cells(R, "S"))
For Each Cell In Rng
With Cell
If IsDate(.Value) Then
For i = 3 To 1 Step -1
' check if the Numberformat contains all of "m", "d" and "y"
If InStr(1, .NumberFormat, Mid("dmy", i, 1), vbTextCompare) = 0 Then Exit For
Next i
If i = 0 Then ' all 3 were found
If MsgBox("Do you want to delete row " & R & " ?", _
vbQuestion Or vbYesNo, _
"Click ""No"" to keep the row") = vbYes Then
Rows(R).Delete
End If
Exit For
End If
End If
End With
Next Cell
Cancel = True ' ends in-cell editing
End If
End Sub
The code carries out two checks on each cell (A:S). It first checks if its value is a date. Then, presuming it is a number, it checks the cell format. If the NumberFormat includes all of the letters 'm", "d" and "y" it is confirmed as a date and released for deletion before which the user can confirm his intention.
This method may require a little fine tuning. Firstly, if the cell has text date a different second check would have to be carried out. Second, if the date format consists of only 2 of the 3 criteria the test for their presence in the mask must be reduced accordingly. Either of these modifications, or both, could be implemented once the nature of your data is better understood.
#J4C3N-14 did you try:
Sub Test_Date()
Dim strDate As String
With ThisWorkbook.Worksheets("Sheet1")
strDate = .Range("A1").Value
If IsDate(strDate) Then
'Code
End If
End With
End Sub
I've searched for similar questions, but the problem I'm having is that I'm adding what I'm looking for to an existing recorded macro that uses commands like:
Range(Selection, Selection.End(xlUp)).Select
to select a range.
This uses the Counta function, assuming there aren't any blanks in the data. I also added IsNumeric in case the value is text. If you wanted to go a step further to make sure everything is neat, you can add this right before the If statement:
Sub Minus_One()
Dim Cell As Range
Dim Cells As Range
Set Cells = Sheets(WhateverSheet).Range("A1:A" & Application.WorksheetFunction.CountA(Range("A:A")))
For Each Cell In Cells
If IsNumeric(Cell.Value) = True Then Cell.Value = Cell.Value - 1
Next Cell
End Sub
Cell.Value = Trim(Cell.Value)
Sub test()
Dim rngTarget As Range
Set rngTarget = Sheet1.Range("A1")
Set rngTarget = Range(rngTarget, rngTarget.End(xlDown))
Dim rngIndex As Range
For Each rngIndex In rngTarget
With rngIndex
.Value = .Value - 1
End With
Next rngIndex
End Sub