I have a ComboBox5 - which I want to populate from an excel worksheet (FaultLog). The values I wish to use are in Column B on the worksheet, but I only want them populated if Column O is blank.
Tried the code below!
I've created a range in the FaultLog sheet called "OpenFaults" but don't know how to filter the range.
Thanks in advance
Private Sub UserForm_Initialize()
Dim myfilter As String
Dim cell As Range, Thisrow As Long, Lastrow As Long
Worksheets(FaultLog).AutoFilterMode = False 'turns off
myfilter = ""
Range("OpenFault").AutoFilter Field:=14, Criteria1:=myfilter
ComboBox5.Clear
'ComboBox1.RowSource = "TestMaterial"
For Each cell In Range("OpenFault")
Thisrow = cell.Row
If Not cell.Rows.Hidden And Thisrow <> Lastrow Then
ComboBox5.AddItem cell.value
End If
Lastrow = Thisrow
Next cell
End Sub
Welcome to SO, Use Userform Initialize function to load combobox as below
Private Sub UserForm_Initialize()
Dim cell As Range, OpenFaults As Range
Set OpenFaults = YOURRANGE 'your values to be populated - range
With Sheets("FaultLog")
If Not WorksheetFunction.CountA(.Range("O:O")) = 0 Then
For Each cell In OpenFaults
ComboBox5.AddItem cell.Value
Next
End If
End With
End Sub
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 am not sure how to combine a Function with a Sub. Most likely, the Sub I have below needs corrections.
I have two tables in two separate sheets: Sheet1 and Sheet2.
Both tables have dynamic number of rows but the first rows always start in the same place and the number of columns in both tables is constant, too. Sheet1 data starts in A2 and ends in R2:R and Sheet2 data starts in A3 and ends in H3:H.
I am trying to implement VLOOkUP in column O of Sheet1, that would populate each cell in column O of Sheet1 with relevant values of column D in Sheet2. So far I managed to come up with code as below.
Public Function fsVlookup(ByVal pSearch As Range, ByVal pMatrix As Range, ByVal pMatColNum As Integer) As String
Dim s As String
On Error Resume Next
s = Application.WorksheetFunction.VLookup(pSearch, pMatrix, pMatColNum, False)
If IsError(s) Then
fsVlookup = ""
Else
fsVlookup = s
End If
End Function
Public Sub Delinquency2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim rCell As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
pSearch = ws1.Range("D2:D" & Cells(Rows.Count, "A").End(xlDown).Row)
pMatrix = ws2.Range("$A3:$H" & Cells(Rows.Count, "C").End(xlDown).Row)
pMatColNum = 4
Set rng = ws1.Range("O2:O" & Cells(Rows.Count, "A").End(xlDown).Row)
For Each rCell In rng.Cells
With rCell
rCell.FormulaR1C1 = s
End With
Next rCell
End Sub
You will need to call the function in your sub using a similar line to below. It then takes your values from your sub and inputs them into the function and returns the value.
You need to dim the ranges in order for them to be recognized correctly in your function. I have updated your code to make it work and you can fiddle around with it to make it work the way you want it to. I also updated a few other spots to figure out the correct ranges, you don't want to use xlDown where you were using it, causes an enormous loop covering cells you don't want it to.
Public Function fsVlookup(ByVal pSearch As Range, ByVal pMatrix As Range, ByVal pMatColNum As Integer) As String
Dim s As String
On Error Resume Next
s = Application.WorksheetFunction.VLookup(pSearch, pMatrix, pMatColNum, False)
If IsError(s) Then
fsVlookup = ""
Else
fsVlookup = s
End If
End Function.
Public Sub Delinquency2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim rCell As Range, pMatrix As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
pSearchCol = ws1.Range("D2:D2").Column
Set pMatrix = ws2.Range("$A3:$H" & ws2.Cells(Rows.Count, "C").End(xlUp).Row)
pMatColNum = 4
Set rng = ws1.Range("O2:O" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
For Each rCell In rng.Cells
With rCell
rCell.Value = fsVlookup(ws1.Cells(rCell.Row, pSearchCol), pMatrix, pMatColNum)
End With
Next rCell
End Sub
I'm trying to create a code to hide rows based on a "HIDE" value in column "AC" on all tabs. I can't get this code to loop through all worksheets. I know the ActiveSheet is probably part of the problem but it's the only way I can get it to hide rows on any of the sheets.
Sub HideRows()
Dim WS_Count As Integer
Dim I As Integer
Dim cell As Range
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
For Each cell In ActiveSheet.Range("AC5:AC14")
With cell
.EntireRow.Hidden = .Value = "HIDE"
End With
Next
Next I
End Sub
This code should work.
Sub HideRows()
Dim ws As Worksheet
Dim lastRow As Integer
Dim actCell As Range
For Each ws In Worksheets
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Get the last row of the table
For Each actCell In ws.Range("AC5:AC" & lastRow) 'Iterate from row 5 until the last row of the table, if you have an fixed range just change it to Range("AC5:AC14") for example.
With actCell
If ws.Range("AC" & .Row) = "HIDE" Then
.EntireRow.Hidden = True
End If
End With
Next
Next
End Sub