How to create userform table to consist of conditional formatting? - excel

So I have a table with conditional formatting already setup (attached).
The values are being highlighted in red when greater than +/-35mm for each constituent separately (dE, dN, dH).
what I'm looking for is to create a userform so the user don't have to navigate to manage rules, instead the threshold for each constituent can be changed directly from the userform.
attached is also a photo of what I need Needed
All help greatly appreciated.
conditional_formatting

not sure what you are asking for but my understanding is you want to click on that record and edit it on a user form and you have your spread sheet already formatted.Use this code to achieve that.
place this code behind your sheet in VBA editor(the one with the data to be manipulated)
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'##################################################
'# Intercept a double click in the record area #
'# and open the edit form 36 #
'##################################################
If Target.Column > 65 Or Target.Row < 1 Then
Exit Sub
End If
Cancel = True
EditRecord
End Sub
and place this one on a module
Sub EditRecord()
Dim CurRow As Integer, CurCol As Integer, intCount1 As Long
Dim RecordEntry
Dim iRow As Long
CurRow = ActiveCell.Row
Range("A" & CurRow).Select
' check if empty row - if so call new record
With ActiveCell
If ActiveCell.Value = "" Then
' check empty rows and create new record goto_empty_row
UserForm1.Show
Exit Sub
End If
End With
' edit existing record - populate form
With UserForm1
.TextBox1.Value = ActiveCell.Offset(0, 0)
.TextBox2.Value = ActiveCell.Offset(0, 1)
.TextBox3.Value = ActiveCell.Offset(0, 2)
.Show
End With
End Sub
and then this on your user form
Private Sub CommandButton1_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2") 'name of the Sheet
'copy the data to the spread sheet
ws.Cells(ActiveCell.Row, 1).Value = Me.TextBox1.Value
ws.Cells(ActiveCell.Row, 2).Value = Me.TextBox2.Value
ws.Cells(ActiveCell.Row, 3).Value = Me.TextBox3.Value
End Sub

Related

VBA to remove formulas and keep values in every row IF a specific cell of the row is NOT empty

I have a basic understanding of Excel formulas but zero experience with VBA. I'm building a basic spreadsheet to keep track of people attendance. This spreadsheet is gonna be completed daily by people with even less understanding than me.
Column B is data validated from a DB table in another sheet. Columns D, E, F, G pull data from the same DB table using XLOOKUP based on the name on column B.
PROBLEM: If something in the DB table changes, like the account number of a person, every past attendance of that person is updated.
Example
I need a simple way to "lock" the data in cells that have been filled, although they should accept manual editing.
So far I'm tryng to put a button somewhere on the sheet that deletes all formulas but keeps tha value of the cells. I did some googling and got this:
Sub Remove_Formulas_from_Selected_Range()
Dim Rng As Range
Set Rng = Selection
Rng.Copy
Rng.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
But I don't know how to adapt the button so it checks every row of the table, and if the Column B of that row is NOT emtpy (meaning the row is filled with a person's data) only THEN deletes the formulas of that row and keeps the values.
Your file must be an .xlsm file. Add an ActiveX button. Double click on it.
Inside the created button_click() sub add one line: call doTheJob
-After paste code below:
Private Sub doTheJob()
Dim rng As Range, rw As Long, c As Long
If TypeName(Selection) = "Range" Then
If MsgBox("Change formulas with Values in selected range?", vbDefaultButton2 + vbExclamation + vbYesNo) = vbYes Then
Set rng = Selection
rw = rng.Rows.CountLarge
Application.ScreenUpdating = False
For c = 1 To rw
If Trim(rng.Cells(c, 2).Value) <> "" Then
rng.Rows(c).Copy
rng.Rows(c).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next
Application.CutCopyMode = False
End If
End If
End Sub
Before click the button you must select the range you interest to replace the formulas with the values.
This sub is for a sheet's module and one "fixed" table name
Private Sub doTheJob()
Dim rng As Range, rw As Long, c As Long
If MsgBox("Change formulas with Values in selected range?", vbDefaultButton2 + vbExclamation + vbYesNo) = vbYes Then
Set rng = Me.ListObjects("NameOfTable").Range
rw = rng.Rows.CountLarge
Application.ScreenUpdating = False
For c = 1 To rw
If Trim(rng.Cells(c, 2).Value) <> "" Then
rng.Rows(c).Copy
rng.Rows(c).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next
Application.CutCopyMode = False
End If
End Sub
Use this code when the range is a Table. Modify the "NameOfTable" to the real name of your table.
This sub is for the Workbook an have to copy in a module inside folder "Modules". In sheets you wand to call this, add an ActiceX button and call the sub like below:
Public Sub doTheJob(ws As Worksheet, tablename As String)
Dim rng As Range, rw As Long, c As Long
If (Not ws Is Nothing) And tablename <> "" Then
Set rng = ws.ListObjects(tablename).Range
Else
MsgBox ("call the doTheJob with prameters a worksheet and a table name")
Exit Sub
End If
If Not rng Is Nothing Then
If MsgBox("Change formulas with Values in range " & tablename & " ?", vbDefaultButton2 + vbExclamation + vbYesNo) = vbYes Then
rw = rng.Rows.CountLarge
Application.ScreenUpdating = False
For c = 1 To rw
If Trim(rng.Cells(c, 2).Value) <> "" Then
rng.Rows(c).Copy
rng.Rows(c).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next
Application.CutCopyMode = False
End If
Else
MsgBox ("doTheJob> Invalid table name")
End If
End Sub
'This sub is in sheets module
Private Sub CommandButton1_Click()
Call doTheJob(Me, Range("TABLE_NAMES").Value)
End Sub

Paste Data To Range From User Form

I am looking for a little assistance with the VBA code in the workbook I have been working on. There is a userform with dependent dropdowns that pulls their values from "Master Sheet" in the workbook. The drop downs are functioning fine. However I have two roadblocks that I have now been able to get past. The first, The dropdowns allow the selection of "Category, Make, Model, and Add To". In the Master Sheet, "Category, Make, Model" Run from Columns A:C. Columns D:G have the equipment's, "Weight, Length, Width, Depth" information. I have not been able to have the information from columns A:F be copied based off the model selection. I have been trying have it paste in a test are for functionality with no luck. However once that would be functioning the "Add To" combo box selection in the user form would specify the range in the ECA worksheet to place that data. In the combo box selection, selecting "Keep" would place that information in range S3:Y16, "Remove" would be range S18:Y32, and "Final" would be range S35:Y47. Since numerous pieces of equipment would be added into each section when adding a piece of equipment it would place that entry in the next empty row of that range.
Link To Workbook
Picture Of Worksheets
Master Sheet
ECA Sheet
Dependent Drop Down Code
Private Sub cmbAddTo_Click()
'code needed to copy and add to selected range
End Sub
Private Sub cmdCancel_Click()
frmUser.Hide
End Sub
Private Sub UserForm_Initialize()
cmbCategory.RowSource = DynamicList(1, Null, 1, "Master Sheet", "Drop Down")
End Sub
Private Sub cmbCategory_Change()
cmbMake.RowSource = DynamicList(1, cmbCategory.Value, 2, "Master Sheet", "Drop Down")
End Sub
Private Sub cmbMake_Change()
cmbModel.RowSource = DynamicList(2, cmbMake.Value, 3, "Master Sheet", "Drop Down")
End Sub
Here is how I did it:
Function wsECA: Refers to the ECA worksheet
Enum SectonType: Numbers the sections
Function ECASection: Returns the range of a section
Function ECANewRow: Returns the range of the next empty row
Sub AddECANewRow: Add variable number of values to the new section row
Code
Public Enum SectonType
stExistingToRemain = 1
stRemoving
stFinal
End Enum
Public Sub AddECANewRow(SectionNumer As SectonType, ParamArray Values() As Variant)
Dim NewRow As Range
Set NewRow = ECANewRow(SectionNumer)
NewRow.Resize(1, UBound(Values) + 1).Value = Values
End Sub
Public Function wsECA() As Worksheet
Set wsECA = ThisWorkbook.Worksheets("ECA")
End Function
Public Function ECANewRow(ByVal SectionNumer As SectonType) As Range
Const LastColumn = 10
Dim Section As Range
Set Section = ECASection(SectionNumer)
Dim LastUsedRow As Long
Dim ColumnLastUsedRow As Long
For c = 2 To LastColumn
With Section.Columns(c)
ColumnLastUsedRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If ColumnLastUsedRow > LastUsedRow Then LastUsedRow = ColumnLastUsedRow
End With
Next
LastUsedRow = LastUsedRow - Section.Row + 1
Set ECANewRow = Section.Cells(LastUsedRow + 1, 2).Resize(1, LastColumn - 1)
End Function
Function ECASection(ByVal SectionNumer As SectonType) As Range
Dim Target As Range
With wsECA
Set Target = Range("P2", .Cells(.Rows.Count, "P").End(xlUp))
End With
Dim MergedArea As Range
Dim Cell As Range
For Each Cell In Target
If Cell.MergeArea.Rows.Count > 1 Then
If MergedArea Is Nothing Then
Set MergedArea = Cell.MergeArea
SectionNumer = SectionNumer - 1
ElseIf MergedArea.Address <> Cell.MergeArea.Address Then
Set MergedArea = Cell.MergeArea
SectionNumer = SectionNumer - 1
End If
If SectionNumer = 0 Then Exit For
End If
Next
If Not MergedArea Is Nothing Then
Set ECASection = Range(MergedArea, MergedArea.EntireRow.Columns("AA"))
End If
End Function
Test
Application.Goto ECANewRow(stExistingToRemain), True
AddECANewRow stExistingToRemain,"Remain" ,3,,"Ford", "Mustang"
Application.Goto ECANewRow(stRemoving), True
AddECANewRow stFinal,"Removing" ,3,,"Chevy", "Tahoe"
Application.Goto ECANewRow(stFinal), True
AddECANewRow stRemoving,"Final" ,3,,"Dodge", "Journey"

Msgbox show only once

Can someone modify my code so that the message box will only show once?
I've been at it for a while now without succes.
The file I'm working on is a register. Whenever the sum of AD13:AJ13 exceed 4 the msg should show,
Prompting action from the user. However as of now, once a cell within the range have exceeded 4 the msgbox shows on all changes within the range, even sums below 4. That's is not intended, i only want the user to be notified once for each cell within the range (AD13:AJ13)
Code:
Private Sub Worksheet_Calculate()
Dim myCell As Range
For Each myCell In Range("AD13:AJ13")
If myCell > 4 Then
MsgBox "Management approval is required once the value exceed 4"
Exit Sub
End If
Next myCell
End Sub
I kind of agree with the comments below the question as Worksheet_Change seems like a more natural trigger. However, the problem could be that this range is not changed directly (i.e. cells have formulae which could depend on cells from other sheets or even other workbooks).
You basically need to somehow save the current state of these cells. Please try this code and see if it helps or opens up a new window of ideas for you.
Private Sub Worksheet_Calculate()
Dim rngSavedState As Range
Dim j As Integer
Dim bMsgBoxShown As Boolean
Set rngSavedState = Range("AD14:AJ14")
Application.EnableEvents = False
With Range("AD13:AJ13")
bMsgBoxShown = False
For j = 1 To .Columns.Count
If .Cells(1, j).Value <> rngSavedState.Cells(1, j).Value Then
rngSavedState.Cells(1, j).Value = .Cells(1, j).Value
If .Cells(1, j) > 4 And Not bMsgBoxShown Then
MsgBox "Management approval is required once the value exceed 4"
bMsgBoxShown = True
End If
End If
Next j
End With
Application.EnableEvents = True
End Sub
You obviously need to change the address of rngSaveState to suit your application.
All the best

from one userform to another userform

i have main user-form 1 which has all the information including list box and when user select the name of the person it will find for duplicate and if user press Yes to duplicate msgbox another user-form 2 will popup requiring password and if user enters the correct password it will popup another user-form 3 which has comment box to be updated against initial duplicate find..
problem is that it only updates comment on 1st line row on sheet 1 (where the data updates) and NOT the actual duplicate it finds using staff ID number in column G in sheet1. it only finds first line which is within User-form1 listbox not the line you have selected in User-form1.
below it is the code which works fine within User-form1 and however it dose not work of what i wants to work when placed in user-form 3
Private Sub CommandButton1_Click()
Dim p As Variant
Dim lCol As Variant
Dim response As Variant
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Jobs_Allocation")
Dim y As Long
Application.EnableCancelKey = xlDisabled
If TextBox1 > False Then
Unload Me
lCol = frmSelector.lstSelector.List(x, 3)
Set findvalue = Sheet1.Range("G:G").Find(What:=lCol, LookIn:=xlValues)
If Not findvalue Is Nothing Then
adr = findvalue.Address
Do
Sheet1.Unprotect Password:="123"
If findvalue.Offset(0, -1).Value = frmSelector.lstSelector.List(x, 2) Then
findvalue.Offset(0, 6).Value = Format(Now, "HH:MM:SS")
findvalue.Offset(0, 7).Value = TextBox1.Value
y = sh.Range("C" & Application.Rows.Count).End(xlUp).Row
Exit Do
End If
Set findvalue = Sheet1.Range("G:G").FindNext(findvalue)
Loop While findvalue.Address <> adr
Set findvalue = Nothing
End If
End If
If TextBox1.Value > 0 Then
MsgBox "You must enter the comment", vbCritical, "Error message"
Exit Sub
End If
End Sub
I'm sorry as I'm not helping you thouroghly, but I think you need to do the loop in your CommandButton1_Click which reside in the third Userform.
I give you a very simple simulation which I hope you can implement it to your code.
From the image above, it's the first userform, in your case it's frmselector.
The listbox is named to lstselector, and (in the image) the selected item is the fourth row. So, the index number is 3, the x value in your case.
I see that to get the lCol value, you do the code :
For x = 0 To Me.lstSelector.ListCount - 1
If Me.lstSelector.Selected(x) Then
**If Me.txtJob.Value = Value = False Then**
lCol = Me.lstSelector.List(x, 3)
So, disregarding the code-line I put in between two asterisk,
based on the image above, we know that the value of the lCol variable is 80.
To get the lCol value (in other words, to get the selected value on the fourth column of the lstselector in frmselector/first_userform) when running the CommandButton1_Click sub of the third userform, we need to do the loop again. Below is the example of the code, which we hope that the code will give lCol value as 80 :
Private Sub CommandButton1_Click()
With frmselector
For x = 0 To .lstselector.ListCount - 1
If .lstselector.Selected(x) Then Exit For
Next
lCol = .lstselector.List(x, 3)
End With
MsgBox "The value of selected selector in frmselector is: " & lCol
End Sub

Trouble getting user form button code working

Got a workbook with two sheets in it. The first is where the data is, and the second has been set up as a "corrections" page. This workbook is sent out to users who are to review it and note inconsistencies/discrepencies. Right now it's set up to highlight the cell via double-click then forward the active cell to a cell at the end of the same row. As it turns out people want more room for comments so I've decided to go with a second sheet that works as a comments sheet. I've got the userform and everything with it done except the "submit" button. When the user double-clicks now the cell is still highlighted, but instead of forwarding to the end of row it opens the user form for comments. I'm trying to get the submit button to do two things:
First, I want it to place the row# of the cell that was highlighted into the first column; and second, I want what the user puts in the textbook to be placed into the second column.
I can get it to enter a value in the first row for the textbox, but I don't know where to start for the row#'s (maybe ActiveCell.Row ?); also, I don't know how to go about getting it set to move down to the next row if the first row already has comments in it (need something with a Row +1 I guess? It's just this one last button that's slowing me up; got the rest done, but I could use some advice on this part of the userform coding. Thanks!
Here's how I'd do it (rough draft):
Private Sub Worksheet_Beforedoubleclick(ByVal Target As Range, Cancel As Boolean)
Const CLR_INDX As Integer = 6
If Target.Interior.ColorIndex = xlNone Then 'If cell is clear
With frmCorrections
Set .CellRange = Target
.HiliteColorIndex = CLR_INDX
.Show
End With
'Or Else if cell is already yellow
ElseIf Target.Interior.ColorIndex = CLR_INDX Then
Target.Interior.ColorIndex = xlNone 'Then clear the background
End If
Cancel = True
End Sub
and the user form code:
Dim m_rng As Range
Dim m_index As Integer
Public Property Set CellRange(rng As Range)
Set m_rng = rng
End Property
Public Property Let HiliteColorIndex(indx As Integer)
m_index = indx
End Property
Private Sub cmdCancel_Click()
Me.Hide
End Sub
Private Sub cmdOK_Click()
Dim cmt As String, NextCell As Range
cmt = Me.txtComment.Text
If Len(cmt) > 0 Then
Set NextCell = ThisWorkbook.Sheets("Corrections").Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0)
With NextCell
.Parent.Hyperlinks.Add Anchor:=NextCell, Address:="", _
SubAddress:=m_rng.Address(False, False, , True), _
TextToDisplay:=m_rng.Address(False, False)
.Offset(0, 1).Value = cmt
End With
m_rng.Interior.ColorIndex = m_index
End If
Me.Hide
End Sub
Private Sub UserForm_Activate()
Me.txtComment.Text = ""
Me.lblHeader.Caption = "Enter comment for cell: " & _
m_rng.Address(False, False)
End Sub
EDIT:
This is what I finally came up with to get it working the way I wanted. On the first worksheet the user can double click on the cell, which then highlights the cell and prompts with the user form. If the user cancels then the highlight is removed and the user can keep working; if they enter anything in the box and submit it then the cell addressis placed in one row on the "Comments" page and the text is enteredone column over in the row corresponding to the original cell's address so I can see where the correction is and what their justification was. Anyways the codes are below.
I use the following for highlighting and calling the form:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
Dim TargRow As Variant
Dim TargCol As Variant
TargRow = Target.Row
TargCol = Target.Column
Header = 8
FirstCol = 0
LastCol = 13
CommentCol = 13
If TargRow > Header And TargCol > FirstCol And TargCol < LastCol Then
'If the cell is clear
If Target.Interior.ColorIndex = xlNone Then
Cancel = True
'Then change the background to yellow
Target.Interior.ColorIndex = 6
Corrections.Show
'Else if the cell background color is already yellow
ElseIf Target.Interior.ColorIndex = 6 Then
'Then clear the background
Target.Interior.ColorIndex = xlNone
End If
End If
'This is to prevent the cell from being edited when double-clicked
Cancel = True
Application.EnableEvents = True
End Sub
And I use this for the user form itself:
Private Sub UserForm_Initialize()
TextBox.Value = ""
End Sub
Private Sub CommandButton2_Click()
Unload Corrections
ActiveCell.Interior.ColorIndex = xlNone
End Sub
Private Sub CommandButton1_Click()
Dim PrevCell As Range
Set PrevCell = ActiveCell
ActiveWorkbook.Sheets("Comments").Activate
Range("A6").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.Value = PrevCell.Address
ActiveCell.Offset(0, 1) = TextBox.Value
Unload Corrections
ActiveWorkbook.Sheets("DataPage").Activate
End Sub

Resources