Problem:
I have a user-form with a comboBox, textBox and button, the items of comboBox are the cells value in range ((A1:A10) for example).
If I enter a new text in comboBox which isn't in the range, I need to add this value to the range, and write it in the textBox, and if it is already exist I want to write it in textBox directly.
I tried to do it but I didn't succeed.
Can anyone help?
Code:
Private Sub UserForm_Initialize()
'cmbx.RowSource = "d2:d100"
Dim cLoc As Range
Dim ws As Worksheet
Set ws = Worksheets("LookupLists")
For Each cLoc In ws.Range("LocationList")
cmbx.AddItem cLoc.Value
Next cLoc
End Sub
If I have understood you correctly then I guess this is what you are tying to do?
For this, please ensure that in design mode, you set the ComboBoxes's .Style property to 0-fmStyleDropDownCombo. This will ensure that you can type in the combobox. :) I have also commented the code so that you will not have a problem understanding the code. But if you still do then simply post back.
My Assumptions: There is nothing below Cell A10
Code:
Dim ws As Worksheet
Dim cLoc As Range
'~~> Prepare your form
Private Sub UserForm_Initialize()
Set ws = ThisWorkbook.Sheets("LookupLists")
For Each cLoc In ws.Range("LocationList")
cmbx.AddItem cLoc.Value
Next cLoc
End Sub
'~~> This will do what you want
Private Sub cmbx_AfterUpdate()
Dim lRow As Long
'~~> Check if the value is in the range
'~~> If not then add it to the range and textbox as well
If Not IFEXISTS(cmbx.Value) Then
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
ws.Range("A" & lRow).Value = cmbx.Value
'~~> Delete the Named range so that we can re-create
'~~> it to include the new value
ThisWorkbook.Names("LocationList").Delete
ThisWorkbook.Names.Add Name:="LocationList", RefersToR1C1:= _
"=LookupLists!R1C1:R" & lRow & "C1"
End If
'~~> Add to textbox
TextBox1.Text = cmbx.Value
End Sub
'~~> function to check if the value is in the textbox or not
Function IFEXISTS(cmbVal As String) As Boolean
For Each cLoc In ws.Range("LocationList")
If UCase(Trim(cLoc.Value)) = UCase(Trim(cmbVal)) Then
IFEXISTS = True
Exit For
End If
Next cLoc
End Function
Related
Using Excel 2007, I understand that I can create worksheet_change event on the worksheet it's created.
But how do I assign a global sub change events to a newly created worksheet?
e.g.
Public Sub DataChange(ByVal Target As Range)
' this will check and see if the user or operator has change the column field
' if they fill in "X", mark the whole row to red color
' otherwise leave it black
Dim KeyCells As Range
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).END(xlUp).Row
Set KeyCells = Range("L2:L" & LastRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Value = "X" Or Target.Value = "x" Then
Target.EntireRow.Font.color = vbRed
Else
Target.EntireRow.Font.color = vbBlack
End If
End If
End Sub
Then in a separate sub procedure in Module1...
Public Sub CreateWorkSheet()
Dim ws As Worksheet
Set ws = Sheets.Add
ws.Name = "Test1"
' Here where I want to set the event but I do not know the syntax
' ws.OnChange = DataChange
Debug.Print "Done"
End Sub
I'm used to assign events on the fly when creating controls (C#/WPF/Pascal), so I figured there would be one in Excel world. Any advice or help would be greatly appreciated.
As mentioned by Jeeped, probably the easiest way would be to copy the sheet that already had the Private Sub Worksheet_Change code behind it, but there is also another way, if you place the following code under ThisWorkbook, whenever a new sheet is created it will add the desired code behind it:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim NewSheet As Worksheet
Set NewSheet = Sheets(ActiveSheet.Name)
Code = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCrLf
Code = Code & "MsgBox ""your code here""" & vbCrLf
Code = Code & "End Sub"
With ThisWorkbook.VBProject.VBComponents(NewSheet.Name).CodeModule
NextLine = .CountOfLines + 1
.InsertLines NextLine, Code
End With
End Sub
The drawback here is that the Trust Settings for Macros would need to be changed by clicking on the Trust access to the VBA project object model:
EDIT:
You could also copy code from one worksheet to another using a similar method:
Sub test()
Dim CodeCopy As VBIDE.CodeModule
Dim CodePaste As VBIDE.CodeModule
Dim numLines As Long
Set CodeCopy = ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
Set CodePaste = ActiveWorkbook.VBProject.VBComponents("Sheet2").CodeModule
numLines = CodeCopy.CountOfLines
'Use this line to erase all code that might already be in sheet2
'If CodePaste.CountOfLines > 1 Then CodePaste.DeleteLines 1, CodePaste.CountOfLines
CodePaste.AddFromString CodeCopy.Lines(1, numLines)
End Sub
I'd go for the last #Jeeped's suggestion
place this code in ThisWorkbook code pane
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
DataChange Target ' this sub will be called at any change of any worksheet passing the chenged range
End Sub
then place this in the same code pane or in any other Module
Public Sub DataChange(ByVal Target As Range)
' this will check and see if the user or operator has change the column field
' if they fill in "X", mark the whole row to red color
' otherwise leave it black
Dim KeyCells As Range
Set KeyCells = Range("L2:L" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not Application.Intersect(KeyCells, Target) Is Nothing Then Target.EntireRow.Font.color = IIf(UCase(Target.Value2) = "X", vbRed, vbBlack)
End Sub
I have a sheet with comboboxes in it. To the left of the comboboxes there is a column where the user can mark positions with an "X" if the combobox to its right should be doing stuff (filling itself with Values that are taken from a dynamic range). I was thinking of something like this but am not managing to make it work:
Dim ComBx As ComboBox
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Tool")
For Each ComBx In ws2.ComboBox
If ComBx.Offset(0, -1).Value = "X" Then
With ComBx
'do stuff
End With
End If
Next ComBx
Any ideas how to reference the position of a combobox anyone? I had to do something similar for checkboxes, where it worked just fine, but this eludes me.
If your Combo-boxes type are Active-X try the code below.
ComBx.TopLeftCell.Offset(, -1).Value returns the value of the cell located one column to the left of the cell where your Combo-Box is located.
Note: besides that, you have a Typo in your code, you defined and set ComBx, but then using If CmBx.Offset(0, -1).Value = "X" Then and also closing with Next CmBx - this shouldn't even compile.
Code
Option Explicit
Sub CmbBoxPosition()
Dim ComBx As OLEObject
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Tool")
For Each ComBx In ws2.OLEObjects
If ComBx.progID Like "Forms.ComboBox.1" Then
' for DEBUG Only
Debug.Print ComBx.Name & " located at " & ComBx.TopLeftCell.Address(False, False, xlA1)
If ComBx.TopLeftCell.Offset(, -1).Value = "X" Then
With ComBx
' the rest of your code goes here
End With
End If
End If
Next ComBx
End Sub
If you are using ActiveX combo boxes then you can run this example to see what the 'TopLeftCell' value (or any offset from it) for all your combo boxes are just to be certain you're looking at the right ones.
Sub GetCombos()
Dim shp As Shape
Dim ws2 As Worksheet
Dim cel As Range
Set ws2 = ActiveWorkbook.Worksheets("Tool")
For Each shp In ws2.Shapes
If shp.FormControlType = xlDropDown Then
Set cel = shp.TopLeftCell.Offset(0, -1)
If cel.Value = "X" Then
Debug.Print "cell at row=" & cel.Row & " column=" & cel.Column & " has an X in it"
' do stuff
End If
End If
Next
End Sub
If it's not the right one you can change the x and y values of shp.TopLeftCell.Offset(x,y) to the correct offset and update your code accordingly.
I have a project in which I have to change to value of a textbox to a value that is searched in a workseet against a vlaue that has been selected from a combobox. for example if I select "A" from the combobox the it should search the worksheet "test" find the input for A and change the text box value to 1 as this is the value entered for A. I have looked at some of the other questions that have been asked here but could not seem to get it to work for me. Below is the code that I have been trying to use.
Private Sub IDComboBox_Change()
Dim domainRange As Range
Dim listRange As Range
Dim selectedString As Variant
Dim lastRow As Long
If IDComboBox.ListIndex <> -1 Then
selectedString = IDComboBox.Value
lastRow = Worksheets("test").Range("A" & Rows.Count).End(xlUp).Row
Set listRange = Worksheets("test").Range("A2:A" & lastRow)
For Each domainRange In listRange
If domainRange.Value = selectedString Then
DomainOwnerTestBox.Value = "test"
End If
Next domainRange
End If
End Sub
Any help would be great. If you need anymore information then please let me know and also please be paient with me as im new to VBA.
Thanks
Try this code. It uses Excel built-in MATCH function to search for value in column A of worksheet 'test'.
Private Sub IDComboBox_Change()
Dim wks As Excel.Worksheet
Dim selectedString As Variant
Dim row As Long
Dim value As Variant
Set wks = Worksheets("test")
If IDComboBox.ListIndex <> -1 Then
selectedString = IDComboBox.value
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks.Columns(1), 0)
On Error GoTo 0
If row Then
value = wks.Cells(row, 2) '<--- assuming that input values are in column 2.
DomainOwnerTestBox.value = value
Else
'Value not found in the worksheet 'test'
End If
End If
End Sub
I am new to VBA and building off of someone else's code, who was newer to VBA than me! Thanks in advance for any tips and advice you may have.
Since I cannot post the image I will attempt to describe the dataset. The data is from a userform, with the bulk of the content in a table range A14:M34, with questions in column A, and data in columns B-M. The first row is a header the user populates identifying the unit inspected. The data below is populated with pull downs with blank, Yes and NO as options, and a few rows with numeric or character strings.
I want to test each cell in a variably sized range for unanswered questions and notify the user if there are any and give them the option to complete the dataset before submitting.
Sub new_p()
Static AbortProc As Boolean
Dim iRow As Long
Dim LastColumn As Long
Dim aCol As Long
Dim ws As Worksheet, WS1 As Worksheet
Dim InputRange As Range
Set ws = Worksheets("PreparationData")
Set WS1 = Worksheets("ColdWeatherPreparation")
Set InputRange = WS1.Range("B15:M34")
If AbortProc Then Exit Sub
'find last column in range
LastColumn = WS1.Cells(14, 2).End(xlToRight).Column
'define variable range of columns
For aCol = 2 To LastColumn
'check that the circuit row is not blank
'If Cells(14, aCol) Is Not Nothing Then
If IsEmpty(InputRange) Then
Msg = "All fields are not populated. Stop submission to resume editing?"
Ans = MsgBox(Msg, vbYesNo)
'if yes stop process
If Ans = vbYes Then
AbortProc = True
Exit Sub
End If
'if no run rest of script
If Ans = vbNo Then
MsgBox "Run without Correcting?"
AbortProc = False
Exit Sub
End If
End If
'End If
Next
'more code here that seems to be working
End Sub
You'll see I have commented out a line I think is redundant. If End(xlToRight) generates the last populated column of the header row then they are not blank, so no need to test. Nonetheless I keep code I am not using until the final checks are done and it is proven to be completely useless. The excessive commenting is to help a large group of non-VBA staffers follow and verify my code before implementing.
So the LastColumn definition seems to work, and I use it again later. When I step through the code it cycles through the correct number of times for my bogus dataset. I feel like the isEmpty is where I am falling down.
If every cell in B15:M34 should be non-blank, then you can do this:
If Application.CountBlank(InputRange)>0 Then
If Msgbox(Msg, vbYesNo) = vbYes Then
'rest of your code
End If
End If
EDIT: this will check each data cell against the corresponding header cell.
Sub new_p()
Static AbortProc As Boolean
Dim iRow As Long
Dim LastColumn As Long
Dim aCol As Long
Dim ws As Worksheet, WS1 As Worksheet
Dim InputRange As Range, rw As Range
Dim HeaderRange As Range
Dim x As Long, Msg As String
Set ws = Worksheets("PreparationData")
Set WS1 = Worksheets("ColdWeatherPreparation")
Set HeaderRange = WS1.Range("B14:M14")
Set InputRange = WS1.Range("B15:M34")
'are you sure about this next line?
'once validation has failed once how does it re-run?
If AbortProc Then Exit Sub
For Each rw In InputRange.Rows
For x = 1 To rw.Cells.Count
If Len(rw.Cells(x).Value) = 0 And _
Len(Headerange.Cells(x).Value) > 0 Then
Msg = "All fields are not populated. Stop submission" & _
" to resume editing?"
If MsgBox(Msg, vbYesNo) = vbYes Then
AbortProc = True
Exit Sub
Else
MsgBox "Run without Correcting?"
AbortProc = False
Exit Sub
End If
End If
Next x
Next rw
'more code here that seems to be working
End Sub
Errors at Len line? Maybe, because Cells has 2 parameters? Cells(RowIndex,ColumnIndex).
Also, you can set LastColumn by:
LastColumn = ActiveSheet.UsedRange.Columns.Count
same thing can be done for rows:
LastRow = ActiveSheet.UsedRange.Rows.Count
Maybe you should move If AbortProc Then Exit Sub inside For loop (as first/last line)
I currently run a macro to compare the most recent sheet of data to the report immediately prior and highlight changes. It works fine on its own. Now, however, we would like to be able to compare selected sheets from any time period. My idea was to pop up a simple userform with two textboxes that the user can use to specify which two reports he wants to compare. I am quite lost though with the idea of trying to declare public variables; what I've got atm is:
Option Explicit
Public shtNew As String, shtOld As String, _
TextBox1 As TextBox, TextBox2 As TextBox
Sub SComparison()
Const ID_COL As Integer = 31 'ID is in this column
Const NUM_COLS As Integer = 31 'how many columns are being compared?
Dim rwNew As Range, rwOld As Range, f As Range
Dim X As Integer, Id
shtNew = CSManager.TextBox1
shtOld = CSManager.TextBox2
'Row location of the first employee on "CurrentMaster" sheet
Set rwNew = shtNew.Rows(5)
Do While rwNew.Cells(ID_COL).Value <> ""
Id = rwNew.Cells(ID_COL).Value
Set f = shtOld.UsedRange.Columns(ID_COL).Find(Id, , xlValues, xlWhole)
If Not f Is Nothing Then
Set rwOld = f.EntireRow
For X = 1 To NUM_COLS
If rwNew.Cells(X).Value <> rwOld.Cells(X).Value Then
rwNew.Cells(X).Interior.Color = vbYellow
rwNew.Cells(33) = "UPDATE"
Else
rwNew.Cells(X).Interior.ColorIndex = xlNone
End If
Next X
End If
Set rwNew = rwNew.Offset(1, 0) 'next row to compare
Loop
Call SUpdates
End Sub
My Suggestion would be to use Comboboxes instead of TextBoxes. Create a userform with two command buttons and two comboboxes and populate the comboboxes in the UserForm_Initialize() event using this code.
Private Sub UserForm_Initialize()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
ComboBox1.AddItem ws.Name: ComboBox2.AddItem ws.Name
Next
End Sub
And then use this code in the OK button to do the comparison.
Private Sub CommandButton1_Click()
Dim shtNew As Worksheet, shtOld As Worksheet
If ComboBox1.ListIndex = -1 Then
MsgBox "Please select the first sheet"
Exit Sub
End If
If ComboBox2.ListIndex = -1 Then
MsgBox "Please select the Second sheet"
Exit Sub
End If
Set shtNew = Sheets(ComboBox1.Value)
Set shtOld = Sheets(ComboBox2.Value)
'~~> REST OF THE CODE HERE NOW TO WORK WITH THE ABOVE SHEETS
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
HTH
Sid
For an easy fix, couldn't you just colour (sorry, I'm English!) the worksheets that you want to refer to, then do something like:
Sub ListSheets()
'lists only non-coloured sheets in immediate window
'(could amend to add to combo boxes)
Dim w As Worksheet
'loop over worksheets in active workbook
For Each w In Worksheets
If w.Tab.Color Then
'if tab color is set, print
Debug.Print w.Name
End If
Next w
Let me know if this solves your problem.