I am trying to go through a column of empty cells in my excel spreadsheet in order to find the row in which the word "Yes" is found. Afterwards, upon finding the word in a particular row, for instance in cell D23, I want it to go over one column to cell E23 and paste the value in that cell into cell B100. Here is what I have so far, but it doesn't seem to be functioning correctly:
Sub Test3()
Dim x As String
x = "Yes"
' Dim found As Boolean
' Select first line of data.
Range("D4").Select
' Set search variable value.
' Set Boolean variable "found" to false.
found = False
' Set Do loop to stop at empty cell.
Do Until ActiveCell.Value = x
' Check active cell for search value.
If ActiveCell.Value = x Then
Range("B100").Value = ActiveCell.Offset(0, 1).Value
found = True
Exit Do
End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
' Check for found.
If found = True Then
MsgBox "Value found in cell " & ActiveCell.Address
Else
MsgBox "Value not found"
End If
End Sub
Thanks!
As #tigeravatar mentioned in his comment, you'd probably be better off using Excel's native functions, but, if you want to do this via VBA, you can do it much more easily and efficiently using the Find function which returns a range if found or else 'Nothing' if not.
Using that, you can test to see what you got back. Try this:
Sub Test3()
Dim x As String
Dim rng As Range
x = "Yes"
Set rng = Range("D4:D10000").Find(x)
If Not rng Is Nothing Then
Range("B100").Value = rng.Offset(0, 1).Value
MsgBox "Value found in cell " & rng.Address
Else
MsgBox "Value not found"
End If
End Sub
Hope it does the trick.
Related
My laboratory is capable of running 20+ different analyses, and we get contracts from about the same 15 companies to do a combination of these analyses. I created an Excel spread sheet to keep track of the work as it comes in, where columns are the 20 different analyses we can run, and rows are the companies. I type in either a checkmark or "NA", depending on whether that company requests that specific analysis. (Each company requests its own combination of analyses).
I need some help with the following:
If I enter "Company 1" in cell A100, I want cell B100 to display "NA". If I enter "Company 2" instead, I want cell D100 to display "NA". And if I enter "Company 3", do nothing, for example. I am OK with adding the check marks manually, as there are other variables that need not be mentioned.
Now, I have been able to develop some toy solution in VBA to some extent (please see code below). However, I have two issues:
In order to run the code, I have to switch to the VBA editor and press F5 after every entry. Instead, I would like it to work like when using formulas for the cells. In other words, if I type in "Company 1" in any cell of column A and hit "Enter", I would like the "NA" to display automatically in the appropriate cells on the row. I guess I could record a macro for this, but the file is shared with many people and I would prefer to avoid that.
In the future I will need to add more companies and analyses, so I need a code I can quickly go in and update. Or maybe have a list of companies that I add to and link it somehow to my code.
Sub writeNA()
For i = 1 To 20 Step 1
x = Cells(i, 1).Value
If x = "Company 1" Then
Cells(i, 2).Value = "NA"
End If
If x = "Company 2" Then
Cells(i, 3).Value = "NA"
End If
If x = "Company 3" Then
Cells(i, 4).Value = "NA"
End If
Next
End Sub
Thank you!
You could add a Worksheet Change event handler, so that whenever the worksheet is changed, the function runs and adds "NA" where needed.
Here is the function that I used for proof of concept. It also adds "NA" when "Company 3" is entered (not sure if that is desired or not).
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Text
Case "Company 1", "Company 2", "Company 3"
Target.Offset(0, 1).Cells.Value2 = "NA"
End Select
End Sub
Update Cells When Entering Values (Worksheet Change Event)
Usually the code has to be copied to different modules (if you want to use it in multiple worksheets). Optionally you can copy both codes into the sheet module.
Adjust the values in the constants section.
No need to run anything, it runs automatically.
If you already have values in the Criteria Column then do a copy/paste and the data will get updated.
Sheet module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
updateCompany Me, Target
End Sub
Standard Module e.g. Module1
Option Explicit
Sub updateCompany( _
ws As Worksheet, _
Target As Range)
Const ProcName As String = ""
On Error GoTo clearError
Const CompanyList As String = "Company 1,Company 2,Company 3"
Const ColsList As String = "B,D,"
Const CriteriaList As String = "NA,NA,"
Const FirstRow As Long = 2
Const CritCol As String = "A"
Dim cel As Range
Dim rng As Range
' Define Processing Range (First Cell to Bottom-Most Cell (1048576)).
Set rng = ws.Columns(CritCol) _
.Resize(ws.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1)
' Define Last Non-Empty Cell.
Set cel = rng.Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' Validate Last Non-Empty Cell
' i.e. check if Processing Range contains a value.
If cel Is Nothing Then
GoTo ProcExit
End If
' Define Source Range (First Cell to Last Non-Empty Cell).
Set rng = rng.Resize(cel.Row - rng.Row + 1)
' Define Target Range.
Set rng = Intersect(Target, rng)
' Validate Target Range i.e. check if the change happened in Source Range.
If rng Is Nothing Then
GoTo ProcExit ' Change didn't happen in Source Range.
End If
' Write values from Company List to Company Array.
Dim Company() As String: Company = Split(CompanyList, ",")
' Write values from Columns List to Columns Array.
Dim Cols() As String: Cols = Split(ColsList, ",")
' Write values from Criteria List to Criteria Array.
Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
Application.EnableEvents = False
' Write values to cells in rows of changed cells.
Dim CurrentMatch As Variant
' Loop through cells of Target Range (can be non-contiguous).
For Each cel In rng.Cells
' Check if current cell is not blank (Empty or "").
If Len(cel.Value) > 0 Then
' Try to find the value in current cell (Company) in Company Array.
CurrentMatch = Application.Match(cel.Value, Company, 0)
' If found...
If IsNumeric(CurrentMatch) Then
' Define the current index of the found value.
CurrentMatch = CurrentMatch - 1 ' -1 because 0-based.
' Check if the value in Columns Array is different than "".
If Cols(CurrentMatch) <> "" Then
' Write value from Criteria Array to cell in current row
' of the column found in Columns Array.
Cells(cel.Row, Cols(CurrentMatch)) = Criteria(CurrentMatch)
Else
' The value in Columns Array is "".
End If
Else
' Couldn't find Company name in Company Array.
End If
Else
' Cell is blank or empty.
End If
Next cel
SafeExit:
Application.EnableEvents = True
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume SafeExit
End Sub
I have a macro that works, but it's not very effective and could be done a lot better.
I simply have a list with all sheet names(they could change so it needs to be dynamic) in one row and in the next row I have a "yes/no" answer that displays if the sheet should be hidden or not.
Example:
Sheet 1, sheet2, sheet3, sheet4,
yes, yes, no, yes
My code so far:
Sub HidingSheets()
'Checking the first sheet
'-------------------------------------------------------------------------------------------
Sheets(Worksheets("Sheet1").Range("E9").Value).Visible = True
Sheets(Worksheets("Sheet1").Range("E9").Value).Activate
If ActiveSheet.Range("A1") = "NO" Then
ActiveSheet.Visible = False
End If
'-------------------------------------------------------------------------------------------
'Checking the second sheet
'-------------------------------------------------------------------------------------------
Sheets(Worksheets("Sheet1").Range("F9").Value).Visible = True
Sheets(Worksheets("Sheet1").Range("F9").Value).Activate
If ActiveSheet.Range("A1") = "NO" Then
ActiveSheet.Visible = False
End If
'-------------------------------------------------------------------------------------------
End Sub
I basically do it manually per every sheet instead of a loop, and this also requires that I need the "yes/no" displayed in every sheet(the "if" formula checking if A1 = "no"). The "yes/no" that s displayed in cell A1 is taken from the matrix that I explained before.
Note: The matrix could be "tranposed", the direction of it doesn't matter.
Thank you in advance if you can help me.
My second attempt is this:
Sub Hiding2()
Dim i As interger
For i = 1 To 10
a = ActiveSheet.Range("E9").Value
If Offset(a(1, 0)) = YES Then
Sheets(a).Visible = True
Else
Sheets(a).Visible = False
End If
Next i
End Sub
But I dont know how to reference the cells that I need, and then get them to move over for every "i".
Sub HideWorksheets()
Dim Cell As Range
Dim Data As Range: Set Data = Worksheets("Sheet1").Range("E9:N9")
On Error Resume Next
For Each Cell In Data
Worksheets(Cell.value).Visible = IIf(Cell.Offset(1, 0) = "YES", xlSheetHidden, xlSheetVisible)
Next Cell
End Sub
You can use Cells instead of Range. With it, you can use column numbers to iterate over some range of columns. There is also other possibilities to exit the code... it depends on the data in your worksheet.
Sub Hiding()
Dim sh as Worksheet, col as Integer
For col = 5 to 100
shName = Worksheets("Sheet1").Cells(9, col).Value
On Error GoTo TheEnd ' in case there is no such sheet
Set sh = Worksheets(shName)
If UCase(sh.Range("A1").Value) = "YES" Then
sh.Visible = xlSheetVisible
Else
sh.Visible = xlSheetHidden
End If
Next col
TheEnd:
End Sub
Can someone help me with retrieving the corresponding row and column when a range is selected via Refedit? I put the pictures below how it looks like.
What I want to do is when I select a range (for example E12:E16) via the "Refedit1" in my userform, it should return the start and end time for the corresponding row (11AM - 3PM +1) and the corresponding date in column (wednesday 26/02/2020)
Next step would be to insert these values immediately inside the 3 DTPickers but this I can do once I have the return values, I think.
I tried all different codes that I found and they always give me either the value that is in the cell ("" in this example), a text string like "sheet1$E$12 or when I use Active.Cell it returns the cell that was active before I selected my range through RefEdit.
Hopefully someone can point me in the right direction, I would help me a lot! Sorry that I couldn`t upload the original excel file but there was to many confidential info in it...
sheet layout
Userform layout
Private Sub CommandButton2_Click()
Dim rRange As Range
Dim strAddr As String
Dim bIsRange As Boolean
'Get the address, or reference, from the RefEdit control.
strAddr = RefEdit1.Value
'Use IsObject to find out if the string is a valid address.
On Error Resume Next
bIsRange = IsObject(Range(strAddr))
On Error GoTo 0
If bIsRange = False Then 'Not Valid
MsgBox "The range is not valid"
RefEdit1.Value = vbNullString
RefEdit1.SetFocus
Exit Sub
End If
'Set the rRange Range variable to the range nominated by the
'RefEdit control. If the Sheet name is also include (eg Sheet2!A1:A10)
'It will act on that range, even if the sheet is not active at the time.
Set rRange = Range(strAddr)
' gives the cell reference as a string
MsgBox strAddr
With rRange
'.Interior.ColorIndex = 16
.Font.Bold = True
'.BorderAround LineStyle:=xlContinuous, Weight:=xlThick
End With
If strAddr = "" Then
'do nothing
Else
Range(strAddr).Value = UserForm1.ComboBox2.Value
End If
End Sub
You can read the date and times like this:
With rRange
'.Interior.ColorIndex = 16
.Font.Bold = True
'.BorderAround LineStyle:=xlContinuous, Weight:=xlThick
startTime = .cells(1).EntireRow.cells(2).Value
endTime = .cells(.cells.count).EntireRow.cells(2).Value
theDate = .cells(1).EntireColumn.cells(5).Value
End With
I have a scenario where I have to look up two columns in worksheet1 and search for match in worksheet2, if any matching column found then replace the value.
Currently I have fixed out to find a match in one column. Here is my code
Sub FindMatch()
Dim x As String
Dim found As Boolean
' Select first line of data.
Range("A2").Select
' Set search variable value.
x = "A"
' Set Boolean variable "found" to false.
found = False
' Set Do loop to stop at empty cell.
Do Until IsEmpty(ActiveCell)
' Check active cell for search value.
If ActiveCell.value = x Then
found = True
Exit Do
End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
' Check for found.
If found = True Then
MsgBox "Value found in cell " & ActiveCell.Address
Else
MsgBox "Value not found"
End If
End Sub
I want to search column "A" and "D" in worksheet 1 against column "A" & "B" in worksheet 2
I searched in SO but didn't see any post similar to my requirement. Can anyone help me out.
Thanks !
This should do it.
Sub FindMatch()
Dim WS_one As Worksheet
Dim WS_two As Worksheet
Set WS_one = Worksheets("Sheet1")
Set WS_two = Worksheets("Sheet2")
' Set worksheets to be used.
Set lastCell = WS_one.Range("A:A").Find _
("*", after:=Cells(1, 1), SearchDirection:=xlPrevious)
'set lastCell as last cell with any value
For x = 1 To lastCell.Row
'Set For loop to run until last cell with value.
With WS_one
'with sheet one only
.Select
Col_ValueA = .Cells(x, 1).Value
Col_ValueD = .Cells(x, 4).Value
'define value to search for
End With
With WS_two
'with sheet two only
.Select
Set findvalue = .Range("A:A").Find _
(Col_ValueA, after:=Cells(1, 1))
'find 1st value equal to column A value
Do
'Do while no match found, and still values to check
If Not findvalue Is Nothing Then
'if value exist then check for match
If .Cells(findvalue.Row, 2).Value = Col_ValueD Then
'check double match
ReplaceValue = .Cells(findvalue.Row, 3).Value
Exit Do
Else
'if second value doesn't match find new Column A value
temp = findvalue.Row
'security check
Set findvalue = .Range("A:A").Find _
(Col_ValueA, after:=Cells(temp, 1))
'find new row
If temp = findvalue.Row Then
'if row doesnt change exit do
Exit Do
End If
End If
Else
'if no column A match found exit do
Exit Do
End If
Loop
End With
If Not ReplaceValue = "" Then
' replacement exists paste in column E and reset replacement value
WS_one.Cells(x, 5).Value = ReplaceValue
ReplaceValue = ""
End If
Next
WS_one.Select
End Sub
Essentially the code matches column A of sheet one with sheet two and if that value matches we check the second value. By the way, you might notice that the code I posted doesn't have select range and Active Cell anymore, try not to use those to often as the are not very secure and tend to make the code slower.
Im trying to write / find a macro that when ran removes the value in a cell if the cells in the column is not a number. IE remove all the cells in column B if a string is found. I have this script to delete empty rows.
Was just trying to re write it so that it can delete the rows based on these condiitions
Sub RemoveRows()
Dim lastrow As Long
Dim ISEmpty As Long
lastrow = Application.CountA(Range("A:XFD"))
Range("A1").Select
Do While ActiveCell.Row < lastrow
ISEmpty = Application.CountA(ActiveCell.EntireRow)
If ISEmpty = 0 Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub
The code iterates backward from the last cell in column B and checks if the value in the cell is numeric using the IsNumeric() function.
If the value is not numeric then it deletes the entire row.
Note: looping backwards (ie. from the last row to first) is necessary when using a loop because the index gets shifted everytime a row gets deleted. Therefore, to avoid skipping some rows backward iteration is required.
Sub KeepOnlyNumbers()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim i As Long
' iterating backwards (from last row to first to keep the logic flow)
For i = ws.Range("B" & ws.Rows.Count).End(xlUp).Row To 1 Step -1
' check whether the value is numeric
If Not IsNumeric(Range("B" & i)) Then
' if not numeric then clear the cells content
Range("B" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub
You can use IsNumeric to evaluate if an object can be evaluated as a number. So you can add:
If Not IsNumeric(ActiveCell) Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
to your Do While loop and it should do what you want. I haven't tested this; let me know if you get an error.
You do not have to iterate backwards even when deleting rows, you can do union and call delete/clear on the unioned range.
Sub UnionOnCondition()
Dim usedColumnB
Set usedColumnB = Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns("b"))
If usedColumnB Is Nothing Then _
Exit Sub
Dim result: Set result = Nothing
Dim cellObject
For Each cellObject In usedColumnB
' skip blanks, formulas, dates, numbers
If cellObject = "" Or _
cellObject.HasFormula Or _
IsDate(cellObject) Or _
IsNumeric(cellObject) Then GoTo continue
If result Is Nothing Then
Set result = cellObject.EntireRow
Else
Set result = Union(result, cellObject.EntireRow)
End If
continue:
Next
If Not result Is Nothing Then _
result.Select ' result.Clear or result.Delete
End Sub