I am using the following code to let users select the cell they want to edit.
Application.InputBox(Prompt:="Click the cell you want to edit.", Title:="Cell To Edit", Type:=8)
How can I change my code so they can only select one cell at a time?
Is this what you are trying?
Sub Sample()
Dim r As Range
Do
On Error Resume Next
Set r = Application.InputBox(Prompt:="Click the single cell you want to edit.", _
Title:="Cell To Edit", _
Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Cells.Count = 1 Then
Exit Do
Else
MsgBox "Please select a single cell only"
Set r = Nothing
End If
Loop
'MsgBox r.Address
End Sub
How about:
Sub qwerty()
Dim r As Range
Set r = Range("A1:A2")
While r.Count <> 1
Set r = Application.InputBox(Prompt:="Click the cell you want to edit.", Title:="Cell To Edit", Type:=8)
Wend
End Sub
Related
I'm setting up a userform to find a company's name. Each company has 10 rows of data. I need the button to select the first row and then stop and only run the findnext if button is clicked again.
Currently my code finds the company's name correctly, but because of the loop it directly select the last row with the company's name. I need it to select the first time the name appears and then findnext only if I click on the button again
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long, c As String
Dim mycell As Range
lastrow = Sheets("Rent Roll").Range("A" & Rows.Count).End(xlUp).Row
c = TextBox1.Text
With Sheets("Rent Roll").Range("C5:C" & lastrow)
Set mycell = .Find(what:=c, LookIn:=xlValues)
If Not mycell Is Nothing Then
firstAddress = mycell.Address
Do
mycell.Select
Set mycell = .FindNext(mycell)
Loop While Not mycell Is Nothing And mycell.Address <> firstAddress
Else
MsgBox ("Not Found")
End If
End With
Exit Sub
End Sub
If I enter "Google", it should select the first row and then stop. Then if I click the button again, use findnext and select the next cell with "Google"
You should be able to to something like this:
Private Sub CommandButton1_Click()
Static lastCell As Range '<< static variables preserve values between calls
Static lastTerm As String
Dim ws As Worksheet, rngSrch As Range
Dim lastrow As Long, i As Long, c As String
Dim f As Range, afterCell As Range
Set ws = ThisWorkbook.Worksheets("Rent Roll")
Set rngSrch = ws.Range(ws.Range("C5"), ws.Cells(Rows.Count, "C").End(xlUp))
c = TextBox1.Text
'new search term?
If c <> lastTerm Then
Set lastCell = Nothing
lastTerm = c
End If
If Len(c) = 0 Then Exit Sub '<< nothing to search for
If lastCell Is Nothing Then
Set afterCell = Rng.Cells(Rng.Cells.Count)
Else
Set afterCell = lastCell
End If
Set f = rngSrch.Find(what:=c, after:=afterCell, LookIn:=xlValues)
If f Is Nothing Then
MsgBox ("'" & c & "' not found")
Else
If f.Row < lastCell.Row Then
MsgBox "Already at the last row" '<< do this, or just keep wrapping round?
Else
f.Select
Set lastCell = f
End If
End If
End Sub
I am new in VBA and I want to write a program that when I manually select 1 or more items from a list the code searches with the name of the item and picks it from another sheet, copies the whole row and pastes it in a 3rd sheet. Is that possible? Preferably with a click of a button the selection is made. Thanks a lot!
Here is an example.
Sub FindAndMove()
Dim Finder As Range
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
.Select 'Optional - show sheet 3
End With
End With
End Sub
Walking through the code:
When they click the button, if they only select 1 cell that's in our list.
Get the value of the item they selected
On Sheet2 - go find that value in column A
If you find it, copy the entire row to the end of Sheet3
You can modify the code by changing the sheet names in Sheet("Sheet1") to whatever you want.
You can also change the list range by changing .Range("A2:A11")
You can change the range to search by changing .Range("A:A")
Sheet 1:
Sheet 2:
Sheet 3: (after we select item 3 and click Find and Move)
Error Handling:
Edit:
Code to find multiple occurrences using FindNext
Sub FindAndMove()
Dim Finder As Range
Dim FirstAddress As Variant
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
FirstAddress = Finder.Address
Do
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
End With
Set Finder = .Range("A:A").FindNext(Finder)
Loop While Not Finder Is Nothing And Finder.Address <> FirstAddress
End With
Sheets("Sheet3").Select 'Optional - Select Sheet3 After.
End Sub
Is there any way to remove error message(object required message) that pops out from the input box whenever the user presses the cancel button?
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
Set rng = Application.InputBox("Copy to", Type:=8)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
End Sub
Not quite sure why you are using the inputbox, you don't even use it in the code.
This should take care of the errors.
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set rng = Nothing
Set inp = Selection
inp.Interior.ColorIndex = 37
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled...", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
End If
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
Application.CutCopyMode = 0
End Sub
That is not a InputBox error. That is your wrong usage. In your code, you immediately set value from InputBox return. That may cause error because of setting empty value("") to an Range object.
So, you need to modify as follow:
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
Dim inputRange As String
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
inputRange = Application.InputBox("Copy to")
If Not IsEmpty(inputRange) Then
Set rng = Range(inputRange)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then
cell.Clear
End If
Next
End If
End Sub
Not tested. Suggestion for you. If it is not work, let me know.
Edit: #TimWilliams I edited the code as follows but it it doesn't run at all now. ANy thoughts?
Sub Item_Fix()
Dim rng As Range, col As Range, arr
Dim sht As Worksheet, c As Range, tmp
On Error Resume Next 'in case user cancels
Set rng = Application.InputBox( _
Prompt:="Please select the Items to update. " & _
" (e.g. Column A or Column B)", _
Title:="Select Range", Type:=8)
On Error GoTo 0
' Set hdr = Application.InputBox( _
' Prompt:="Does your selection contain headers?", _
' Title:="Header Option")
hdr = MsgBox("Does your selection contain a header?", vbYesNo + vbQuestion, "Header Option")
If rng Is Nothing Then Exit Sub
If rng.Columns.Count > 1 Then
MsgBox "Please select only a single column!", vbExclamation
Exit Sub
End If
Set sht = rng.Parent
Set col = sht.Range(sht.Cells(2, rng.Column), _
sht.Cells(sht.Rows.Count, rng.Column).End(xlUp))
Application.ScreenUpdating = False
If hdr = vbYes Then
For Each c In col.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 And Len(tmp) < 9 And Row > 1 Then
c.NumberFormat = "#"
c.Value = Right("000000000" & tmp, 9)
End If
Next c
End If
If hdr = vbNo Then
For Each c In col.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 And Len(tmp) < 9 Then
c.NumberFormat = "#"
c.Value = Right("000000000" & tmp, 9)
End If
Next c
Application.ScreenUpdating = True
End If
End Sub
I'm trying to write a function that will insert leading zeroes into a column that a user specifies. Honestly, I would love for this to be like the Excel Menu Data > Remove Duplicates option. I want to click on a menu button and then select my range and let it do the magic, unfortunately I keep getting errors when trying to deduce the column that has been selected. Other than that issue, it should work fine. My code is below. Any help would be greatly appreciated!
Sub Item_Fix()
'Set Item = Application.InputBox("Select the range that contains the Items").Column
Set IC = Application.InputBox(Prompt:= _
"Please select the Range of Items. (e.g. Column A or Column B)", _
Title:="SPECIFY RANGE", Type:=8).Column
'Set Items = vRange.Column
Set Items = IC.Column
Lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Items.EntireColumn.Offset(0, 1).Insert
For i = 2 To Lastrow
Cells(i, Items + 1).Formula = "=Text(" & Cells(i, Items) & ",""000000000"")"
Next i
NewColumn = Items + 1
NewColumn.EntireColumn.Copy
Items.PasteSpecial xlPasteValues
NewColumn.EntireColumn.Delete
End Sub
#Jeeped has the right approach I think, but since you asked for a version of your original...
Sub Item_Fix()
Dim rng As Range, col As Range, arr
Dim sht As Worksheet, c As Range, tmp
On Error Resume Next 'in case user cancels
Set rng = Application.InputBox( _
Prompt:="Please select the Items to update. " & _
" (e.g. Column A or Column B)", _
Title:="Select Range", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
If rng.Columns.Count > 1 Then
MsgBox "Please select only a single column!", vbExclamation
Exit Sub
End If
Set sht = rng.Parent
Set col = sht.Range(sht.Cells(2, rng.Column), _
sht.Cells(sht.Rows.Count, rng.Column).End(xlUp))
Application.ScreenUpdating = False
For Each c In col.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 And Len(tmp) < 9 Then
c.NumberFormat = "#"
c.Value = Right("000000000" & tmp, 9)
End If
Next c
Application.ScreenUpdating = True
End Sub
Let the user select a group of cells to receive the procedure. An InputBox method seems like one extra step and an impediment to the workflow.
Sub make_DUNS_number()
Dim duns As Range, tmp As String
For Each duns In Selection
'possible error control on non-numeric values
'if isnumeric(duns.value2) then
tmp = Right("000000000" & Format(duns.Value2, "000000000;#"), 9)
duns.NumberFormat = "#"
duns.Value2 = tmp
'end if
Next duns
End Sub
With that in place, you should have no trouble adding it to the QAT. See Add Buttons to the Quick Access Toolbar and Customize Button Images for more information.
Selection = Evaluate("index(text(" & Selection.Address & ",""'000000000""),,1)")
I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub