I have a worksheet named "Input" with a Button (ActiveX) and a TextBox (ActiveX). I used VBA to check value of the TextBox when a user clicks the button, but the code cant find the textbox.
My code for the button:
Sub Toevoegen()
Dim invoerenws As Worksheet
Dim overzichtws As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "TextBox1"
Set invoerenws = Worksheets("invoeren")
Set overzichtws = Worksheets("overzicht")
With overzichtws
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With invoerenws
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With overzichtws
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
overzichtws.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With invoerenws
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
If the values are still inside the textBox then you have to reference the object or the control. you can do it like this:
textBox.value = worksheet.cells(1,1)
What this will do is display the value of textBox form control to cell A1. I know this is not what you are looking for but this is the simplest way of showing you how to reference userform objects or controls. You can find the name of a textBox control on a window like this:
You need to use the (Name) when referencing textboxes
Related
I have growing data files and in a certain column is not fill out. I have the code to fill the data, though I want to make a button to call userform for user to fill in the range so that the code works within the range provided by the user(since data is adjusted by the user itself). The code to fill the blank cell is;
Sub fillblank()
Dim range As Range
Dim cell As Range
Dim value As String
Set range = Sheets("Sheet1").Range("E4:E15")
For Each cell In range
If Trim(cell.Value) <> "" Then
value = cell.Value
Else
cell.Value = value
End if
Next cell
End Sub
I would like the user to enter the range (E4:E15) in userform. How to do the userform if its dependent only range? Thanks stackoverflow.com.
Put a text box in userform and name it txtRng. Then declare a variable named MyRng as String. Assign that text box value to MyRng variable and use this variable as argument of range like...
Set range = Sheets("Sheet1").Range(MyRng)
So, full code will be like as below
Sub fillblank()
Dim range As range
Dim cell As range
Dim value As String
Dim MyRng As String
MyRng = UserForm1.txtRng 'Use your form name here
Set range = Sheets("Sheet1").range(MyRng)
For Each cell In range
If Trim(cell.value) <> "" Then
value = cell.value
Else
cell.value = value
End If
Next cell
End Sub
I also suggest you to not use range, value as variable because some of these reserve keyword. It may cause misbehave of output.
You could use the InputBox() method and have the user select a range:
Sub fillblank()
Dim myRange As Range
Dim cell As Range
Dim myValue As String
Set myRange = Application.InputBox( prompt:="Select a range", Type:=8)
For Each cell In myRange
If Trim(cell.Value) <> "" Then
myValue = cell.Value
Else
cell.Value = myValue
End if
Next
End Sub
or you could add a RefEdit control to your userform and process it
Sub fillblank()
Dim cell As range
Dim myValue As String
For Each cell In range(Me.RefEdit1.Text)
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
In this case, since the user could input an invalid range, you may want to add a validation function (named GetRange in my following example)
Sub fillblank()
Dim myRange As range
If Not GetRange(Me.RefEdit1.Text, myRange) Then
MsgBox "Select a valid range "
Me.RefEdit1.SetFocus
Exit Sub
End If
Dim cell As range
Dim myValue As String
For Each cell In myRange
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
Function GetRange(RefEditText As String, myRange As range) As Boolean
On Error Resume Next
Set myRange = range(RefEditText)
On Error GoTo 0
GetRange = Not myRange Is Nothing
End Function
finally, here is an alternative method (no loops) to fill blank cells as you're wanting to do:
Sub fillblank()
With range(Me.RefEdit1.Text).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.value = .value
End With
End Sub
To ask the user for a range you could use InputBox(Type:=8)
The code bellow will accept only one column
If an entire column is selected (A:A) or multiple columns it adjusts to the total rows in UsedRange and first column in selection
Option Explicit
Public Sub FillBlanks()
Dim selectedCol As Range, itm As Range, lr As Long
On Error Resume Next
Set selectedCol = Application.InputBox(Prompt:="Select column:", Type:=8)
On Error GoTo 0
If selectedCol Is Nothing Then Exit Sub 'User cancelled selection
With selectedCol
.Parent.Activate
lr = .Parent.UsedRange.Rows.Count
If .Columns.Count > 1 Then Set selectedCol = .Resize(.Rows.Count, 1)
If .Rows.Count < 2 Or .Rows.Count > lr Then Set selectedCol = .Resize(lr - .Row + 1, 1)
selectedCol.Select
End With
For Each itm In selectedCol
If Len(Trim$(itm)) = 0 And itm.Row > 1 Then itm.Value2 = itm.Offset(-1).Value2
Next
End Sub
Note: It's not recommended to name your variables with special VBA keywords
Dim range As Range - Range is the most important object in Excel
Dim value As String - Value is the most important property of the Range object
I am trying to connect my NIGOcomboBox list with the ListBox1 list on my worksheet (DropDownMenus). Currently I have the NIGOcomboBox populating from
Private Sub UserForm_Initialize()
Dim cell As Range
'Populate NIGO dropdown menu from "DropDownMenus worksheet.
For Each cell In .Range("B2:B" & .Cells(Rows.Count, 2).End(xlUp).Row)
If Not IsEmpty(cell) Then NIGOcombobox.AddItem cell.Value
Next cell
End With
Then I have a ListBox that populates as follows:
Private Sub NIGOcombobox_Change()
With Worksheets("DropDownMenus")
.Activate
Select Case NIGOcombobox
'Populate NIGO Reason list by dropdown menu selection.
Case "AMRF"
For Each cell In .Range("C3:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
If Not IsEmpty(cell) Then ListBox1.AddItem cell.Value
Next cell
Case "OATS"
For Each cell In .Range("D3:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
If Not IsEmpty(cell) Then ListBox1.AddItem cell.Value
Next cell
Case Else
MsgBox "Please select a NIGO Reason"
End Select
End With
End Sub
Its not exactly working as planned. I need to make this so when the next person comes along to add a new item to the NIGOcombox it auto selects the next row so they do not have t adjust the code.
Example
NIGOCombobox is in sheet (DropDownMenus) column ("A2:A") and the ListBox1 is also on sheet (DropDownMenus) but starts on column ("C3:C"). Each column after - D, E, F G etc. correspond with the next NIGOCombobox item.
So, A2 =("C3:C"), B2 =("D3:D), C2 = ("E3:D") and so on. Than way when a new item is entered into the NIGOCombobox it auto attaches to the next Listbox row.
Hope this makes sense! Thank you
Not sure of your aim. The following code will load column B in NIGOcombobox and then seach for the selected value in the first row of Worksheets("DropDownMenus"). So, if you transpose your column B into the first row of Worksheets("DropDownMenus") (starting in C1), that row will behave like a "header", and this might work. PS: if you want to add to previously selected items, delete the line ListBox1.Clear
Private Sub UserForm_Initialize()
Dim cell As Range
'Populate NIGO dropdown menu from "DropDownMenus worksheet.
For Each cell In Worksheets("DropDownMenus").Range("B2:B" & Worksheets("DropDownMenus").Cells(Rows.Count, 2).End(xlUp).Row)
If Not IsEmpty(cell) Then NIGOcombobox.AddItem cell.Value
Next cell
End Sub
Private Sub NIGOcombobox_Change()
Dim TheValueInCombobox As String
Dim TheHeader As Range
Dim TheHeaderColumn As Long
Dim LastRow As Long
ListBox1.Clear
TheValueInCombobox = NIGOcombobox.Value
Set TheHeader = Worksheets("DropDownMenus").Range("A1:Z1").Find(TheValueInCombobox) 'You might want to expand the range
TheHeaderColumn = TheHeader.Column
LastRow = Worksheets("DropDownMenus").Cells(Rows.Count, TheHeaderColumn).End(xlUp).Row
For Each cell In Worksheets("DropDownMenus").Range(Cells(3, TheHeaderColumn), Cells(LastRow, TheHeaderColumn))
If Not IsEmpty(cell) Then ListBox1.AddItem cell.Value
Next cell
End Sub
EDIT:
There is no need to have the values for populating NIGOcombobox in a dedicated column: you can scan the headers directly. This way data structure would be clearer (I think).
Private Sub UserForm_Initialize()
Dim cell As Range
Dim lColumn As Long
'Populate NIGO dropdown menu from "DropDownMenus worksheet.
lColumn = Worksheets("DropDownMenus").Cells(1, Columns.Count).End(xlToLeft).Column
For Each cell In Worksheets("DropDownMenus").Range(Cells(1, 3), Cells(1, lColumn))
If Not IsEmpty(cell) Then NIGOcombobox.AddItem cell.Value
Next cell
End Sub
Private Sub NIGOcombobox_Change()
Dim TheValueInCombobox As String
Dim TheHeader As Range
Dim TheHeaderColumn As Long
Dim LastRow As Long
Dim lColumn As Long
ListBox1.Clear
TheValueInCombobox = NIGOcombobox.Value
lColumn = Worksheets("DropDownMenus").Cells(1, Columns.Count).End(xlToLeft).Column
Set TheHeader = Worksheets("DropDownMenus").Range(Cells(1, 3), Cells(1, lColumn)).Find(TheValueInCombobox)
TheHeaderColumn = TheHeader.Column
LastRow = Worksheets("DropDownMenus").Cells(Rows.Count, TheHeaderColumn).End(xlUp).Row
For Each cell In Worksheets("DropDownMenus").Range(Cells(3, TheHeaderColumn), Cells(LastRow, TheHeaderColumn))
If Not IsEmpty(cell) Then ListBox1.AddItem cell.Value
Next cell
End Sub
I have a large table and the information I'm wanting to add comments to falls within Range(D11:CY148). I have two tabs - "Finish Matrix" (main) and "list" (hidden - has 2 columns).
I have two issues.
First issue - Code works to a degree, after I type my values within a cell it automatically adds comments based off info in another sheet. The problem is there is too many cells to be manually typing into and if I copy and paste the code doesn't run. I created a CommandButton and wanted it to refresh the entire table with comments depending if the cells had the values that fall within "list". I tried to create a call out to Worksheet_Change but to no avail. (I'm a beginner so it'll help if you explain)
Second issue - I'm assuming it'll get fixed with whatever suggestion that works. Occasionally after typing into a cell I would get an error. Can't remember the error name but it is one of the common ones, atm the error isn't popping up but surely it'll come back since I didn't do anything different to the code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:CX")) Is Nothing Then _
If Intersect(Target, Columns("CY")) Is Nothing Then Exit Sub
Dim lRow As Integer
lRow = Sheets("list").Range("A1").End(xlDown).Row
If Target.Value = vbNullString Then Target.ClearComments
For Each cell In Sheets("list").Range("A1:A" & lRow)
If cell.Value = Target.Value Then
Target.AddComment
Target.Comment.Text Text:=cell.Offset(0, 1).Value
End If
Next cell
End Sub
Thanks for any and all help!
You are basically missing the For Each Cell in Target part...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMain As Worksheet, wsList As Worksheet
Dim cell As Range
Dim vCommentList As Variant
Dim i As Long, lLastRow As Long
Dim sValue As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsMain = Target.Parent
Set Target = Intersect(Target, wsMain.Range("D11:CY148"))
If Target Is Nothing Then Exit Sub
Set wsList = wsMain.Parent.Sheets("list")
lLastRow = LastRow(1, wsList)
' Read Comment List into Variant (for speed)
vCommentList = wsList.Range("A1:B" & lLastRow)
Target.ClearComments
' This...For each Cell in Target...is what you were missing.
For Each cell In Target
sValue = cell
For i = 1 To UBound(vCommentList)
If sValue = vCommentList(i, 1) Then
AddComment cell, CStr(vCommentList(i, 2))
Exit For
End If
Next
Next
ErrHandler:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Proper way to find last row ...
Public Function LastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
LastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
Add Comment Sub the allows appending is needed...
Public Sub AddComment(Target As Range, Text As String)
If Target.Count = 1 Then
If Target.Comment Is Nothing Then
Target.AddComment Text
Else
Target.Comment.Text Target.Comment.Text & vbLf & Text
End If
End If
End Sub
Untested, but this will take all the values in Range(D11:CY148) and add a comment based on a lookup from Sheet "list".
Sub testy()
Dim arr As Variant, element As Variant
Dim i As Long, j As Long, listItems As Long, rwLast As Long, clLast As Long
Dim comm As String
Dim rng As Range, cell As Range
listItems = Sheets("list").Range("A1").End(xlDown).Row
rwLast = Cells.SpecialCells(xlCellTypeLastCell).Row ' Adjust to fit your needs
clLast = Cells.SpecialCells(xlCellTypeLastCell).Column 'Idem
Set rng = Sheets("list").Range("A1:A" & listItems)
arr = Range("D11:CY148").Value
With Worksheets("Finish Matrix")
For i = 1 To rwLast - 10 'Adjust to make it more general, this is pretty rough
For j = 1 To clLast - 3 'Idem
If i = 3 Then
End If
comm = ""
For Each cell In rng
If arr(i, j) = cell.Value Then
comm = comm & Chr(13) & cell.Offset(0, 1).Value
End If
Next cell
If Not (comm = "") Then
.Cells(10, 3).Offset(i, j).ClearComments
.Cells(10, 3).Offset(i, j).AddComment
.Cells(10, 3).Offset(i, j).Comment.Text Text:=comm
End If
Next j
Next i
End With
End Sub
I need VBA code to check for blank cells within a range. If there are any blanks within that range, a box should come up to allow you to type in what you want to replace the blanks with. The code below does what I want, but the prompt ALWAYS appears, even if there aren't any blanks. How do I make it so the box only appears if there are blanks?
Sub ReplaceBlanks()
Dim Lastrow As Integer
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("D84:D" & Lastrow).Select
Dim cell As Range
Dim InputValue As String
On Error Resume Next
InputValue = InputBox("Enter value that will fill empty cells in selection", "Fill Empty Cells")
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = InputValue
End If
Next
End Sub
Sub ReplaceBlanks()
Dim Lastrow As Integer
Dim srchRng As Range
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Set srchRng = Range(Cells(84, 4), Cells(Lastrow, 4))
Dim InputValue As String
If srchRng.Count - WorksheetFunction.CountA(srchRng) > 0 Then
InputValue = InputBox("Enter value that will fill empty cells in selection", _
"Fill Empty Cells")
srchRng.SpecialCells(xlCellTypeBlanks).Value = InputValue
End If
End Sub
This also adds in the range variable, so you avoid using .Select. It also assumes that you only want ONE inputvalue. If you want it to trigger for each empty cell, put the inputValue = ... in the If IsEmpty(cell) loop.
An alternative to your If a cell is empty loop, is a one line fix:
Range(Cells(84,4),Cells(lastRow,4)).SpecialCells(xlCellTypeBlanks).Value = InputValue. That will take ALL blanks in D84:DlastRow and fill in with whatever the InputValue is. No need to loop.
Sub ReplaceBlanks()
Dim Lastrow As Integer
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("D84:D" & Lastrow).Select
Dim cell As Range
Dim InputValue As String
On Error Resume Next
For Each cell In Selection
If IsEmpty(cell) Then
InputValue = InputBox("Enter value that will fill empty cells in selection", _
"Fill Empty Cells")
cell.Value = InputValue
End If
Next
End Sub
just move the line to the right place :D
YourRange.Cells.Count - WorksheetFunction.CountA(YourRange) will give you the count of blanks so you can check if you have blanks:
Sub ReplaceBlanks()
Dim Lastrow As Integer
Lastrow = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 'Use 4 as it is the D column you are working with
Dim cel As Range 'Use cel as CELL can be confused with functions
Dim InputValue As String
If Range("D84:D" & Lastrow).Cells.Count - WorksheetFunction.CountA(Range("D84:D" & Lastrow)) > 0 Then
InputValue = InputBox("Enter value that will fill empty cells in selection", "Fill Empty Cells")
For Each cel In Range("D84:D" & Lastrow)
If IsEmpty(cel) Then
cel.Value = InputValue
End If
Next
End If
End Sub
I am trying to hide a column A1 in my sheet using vba. But am getting a error "unable to set hidden property of range class"
Here is my code:
ActiveWorkbook.Sheets("Project").Activate
ActiveSheet.Unprotect password
Dim cmt As comment
Dim iRow As Integer
For iRow = 1 To Application.WorksheetFunction.CountA(Columns(1))
Set cmt = Cells(iRow, 1).comment
If Not cmt Is Nothing Then
Cells(iRow + 1, 1) = Cells(iRow, 1).comment.Text
Cells(iRow, 1).comment.Delete
Else
MsgBox "No Comments"
End If
Next iRow
MsgBox ActiveSheet.ProtectionMode
ActiveSheet.Columns(1).Select
Selection.EntireColumn.Hidden = True
Am getting error in the line
Selection.EntireColumn.Hidden = True
I have included MsgBox to check whether the sheet is protected and is there any comment available in the cells of that column.
1st MsgBox returns as No Comments and 2nd returns as false.
So the sheet is not protected and comment is also not present.
Confused on why getting the error eventhough.
Please help me out
UPDATE:
I have changed my code like this:
ActiveWorkbook.Sheets("Project").Activate
Dim sh As Shape
Dim rangeToTest As Range
Dim lRow As Long
Dim c As Range
lRow = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Set rangeToTest = ActiveSheet.Range("A1:A" & lRow)
For Each c In rangeToTest
For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh
Next c
ActiveSheet.Range("A1").EntireColumn.Hidden = True
And it worked. But I have added comments to other column headers which i get on hovering mouse over the cell. Am not getting the comments now..
Does deleting shapes have something to do with comments?
Actually i have added comments to other columns in my sheet. Comments come under activesheet.shapes so due to that i am unable to hide the column. Once I have set the placement for that it works perfectly
This code does the trick:
ActiveWorkbook.Sheets(sheetname).Activate
Dim sh As Shape
Dim rangeToTest As Range
Dim lRow As Long
Dim c As Range
lRow = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Set rangeToTest = ActiveSheet.Range("A1:A" & lRow)
For Each c In rangeToTest
For Each sh In ActiveSheet.Shapes
sh.Placement = xlMoveAndSize
Next sh
Next c
ActiveSheet.Range("A1").EntireColumn.Hidden = True
You can't use entirecolumn and hidden properties directly on columns, those properties works for Range() object only. Take Range("A1").EntireColumn.Hidden = True
Thanks
Nag
You should remove this line also
ActiveSheet.Columns(1).Select
Your code just works fine for me?? I'm in excel 2010, maybe you're not. Plugged it in as is and password protected the sheet as well. Comments or not made no difference, it will hide it whatever.
Two things
INTERESTING READ
Don't use Application.WorksheetFunction.CountA(Columns(1)) to find the last row. See THIS link on how to find the last row.
Is this what you are trying (UNTESTED)?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim cmt As Comment
Dim iRow As Long, lRow As Long
Dim Password As String
'~~> Change as applicable
Password = "Blah Blah"
Set ws = ThisWorkbook.Sheets("Project")
With ws
.Unprotect Password
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For iRow = 1 To lRow
Set cmt = .Cells(iRow, 1).Comment
If Not cmt Is Nothing Then
.Cells(iRow + 1, 1) = .Cells(iRow, 1).Comment.Text
.Cells(iRow, 1).Comment.Delete
Else
'MsgBox "No Comments"
Debug.Print "No Comments"
End If
Next iRow
.Columns(1).EntireColumn.Hidden = True
.Protect Password
End With
End Sub