Maybe this post is a tad long but I hope you will read it and have some input for me.
I have been working to make a user form for Welder Qualification Test Records (WQTR). Since the form is 107 fields, I have created a fairly involved Module that allows the user to save their progress. Rather type lengthy explanations, I'm adding the completed Module here. I have made detailed comments in the code but let me know if something needs explaining.
Everything compiles fine and it does what I expect it to do with one exception. I assumed (not sure why) that the order the TextBoxes are being read by the script and entered into the worksheet (all in one row) would be in sync with the tab order. However, that is not case. In fact, I can see no particular order at all. I think this has something to do with how I am creating the headers for columns based on the Labels in the user form, but I'm not sure. I did make sure that the labels are in the proper order in the tab order even though I set all label's TabStop properties for to False.
Below is the code I have in the module. I have several other modules but none of them should have any bearing on this issue.
Option Explicit
Dim ws As Worksheet
Dim welderNameEntered As String
Dim welderName_ As Variant
Dim welderFirstName As String
Dim welderMiddlename As String
Dim welderLastName As String
Dim sheetName As String
Dim arrayLength As Integer
'********************************************************************************
'***Controls the order of execution in this module for all Subs and Functions.***
'********************************************************************************
Public Sub TempSaveProgress()
Application.ScreenUpdating = False
Call SplitName
funcCheckAndAddNewSheet sheetName
Call SaveData
Call Protection.DangerMouse(sheetName)
Application.ScreenUpdating = True
ActiveWorkbook.Save
End Sub
'************************************************************************************
'***Splits the Welders's first and last names by the space between them and grabs****
'***the first three characters of each. Sets the value of the sheetname variable***
'************************************************************************************
Sub SplitName()
welderNameEntered = WQTR_Form.welderNameText.Value
welderName_ = Split(welderNameEntered, " ")
Dim arrayLength As Integer
arrayLength = UBound(welderName_) - LBound(welderName_) + 1
Dim answer As Long
If arrayLength = 0 Then
Call ArrayLengthZero
Exit Sub
ElseIf arrayLength = 1 Then
Call ArrayLengthOneAndThree
Exit Sub
ElseIf arrayLength = 2 Then
welderFirstName = Left(welderName_(0), 3)
welderLastName = Left(welderName_(1), 3)
sheetName = "Temp-" + welderLastName + "-" + welderFirstName
ElseIf arrayLength = 3 Then
welderFirstName = Left(welderName_(0), 3)
welderMiddlename = Left(welderName_(1), 1)
welderLastName = Left(welderName_(2), 3)
sheetName = "Temp-" + welderLastName + "-" + welderFirstName + "-" + welderMiddlename
ElseIf arrayLength > 3 Then
Call ArrayLengthOneAndThree
Exit Sub
End If
End Sub
'**************************************************************************************
'***Adds and new worksheet after all other worksheets and gives it a temporary name.***
'**************************************************************************************
Function funcCheckAndAddNewSheet(argCheckAndAdd As String)
For Each ws In ThisWorkbook.Worksheets
If argCheckAndAdd = ws.Name Then
Call SheetNameAlreadyExists
End If
Next ws
If sheetName <> "" Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = argCheckAndAdd
End If
End Function
'*****************************************
'***Message if the arrayLength is zero ***
'*****************************************
Sub ArrayLengthZero()
Dim answer As Long
answer = MsgBox("You must enter a welder's name in order to Save Your Progress.", vbOKOnly, "No name?")
End Sub
'**************************************************
'***Message if the arrayLength is One or Three. ***
'**************************************************
Sub ArrayLengthOneAndThree()
Dim answer As Long
answer = MsgBox("The Welder's Name you entered is not valid. The name must conform to one these examples:" + _
vbNewLine + vbNewLine + _
" 1. FirstName LastName as in John Doe." + vbNewLine + _
" 2. FirstName MiddleName LastName as in Franklin Deleno Roosevilt." + vbNewLine + _
" 3. FirstName MiddleInitial LastName as in Joe D. Public." + vbNewLine + vbNewLine + _
"You also must make sure that names are no more than three names. " + _
"A name such as Roy Wayne David Johnson will not work. " + _
"In such cases, one of the two middle names must be omitted." _
, vbOKOnly, "Name is incorrect")
End Sub
'******************************************************************************
'***Message if sheetName matches the name of an already existing worksheet. ***
'******************************************************************************
Sub SheetNameAlreadyExists()
Dim answer As Long
answer = MsgBox("A WorkSheet by by the name " + sheetName + " already exists." + _
" Did you already Save Progress for this welder on another occasion?" + _
" If so, would you like to overwrite the data in the Worksheet named " + _
sheetName + "?", vbYesNo, sheetName + " Already Exists.")
If answer = vbYes Then
Call SafeMouse
Worksheets(sheetName).Activate
Application.DisplayAlerts = False
Worksheets(sheetName).Delete
Application.DisplayAlerts = True
Exit Sub
Else
Exit Sub
End If
End Sub
'****************************************************************************************
'***Sets the Active Sheet for all of the subs it calls. Again, this basically ***
'***controls the order of execution. Then does some minor worksheet level formatting. ***
'****************************************************************************************
Private Sub SaveData()
Worksheets(sheetName).Activate
Call LabelNames
Call LabelCaptions
Call TextBoxText
Call DeleteEmptyColumns
'-----Worksheet-level Formatting-----
Worksheets(sheetName).range("A1:DD1").Font.Bold = True
Worksheets(sheetName).Columns("A:DD").AutoFit
End Sub
'***************************************************************************************
'***Takes the names of all of the form lables and enters them in the first row of the***
'***active sheet. ***
'***************************************************************************************
Private Sub LabelNames()
Dim ctlLblName As control
Dim col As Integer: col = 0
For Each ctlLblName In WQTR_Form.Controls
If TypeName(ctlLblName) = "Label" Then
col = col + 1
Cells(1, col).Value = ctlLblName.Name
Cells(1, col).Interior.ColorIndex = 15
End If
Next ctlLblName
End Sub
'*******************************************************************************************
'***Takes the captions of all of the form lables and enters them in the second row of the***
'***active sheet. ***
'*******************************************************************************************
Private Sub LabelCaptions()
Dim ctlLblCaption As control
Dim col As Integer: col = 0
For Each ctlLblCaption In WQTR_Form.Controls
If TypeName(ctlLblCaption) = "Label" Then
col = col + 1
Cells(2, col).Value = ctlLblCaption.Caption
Cells(2, col).Interior.ColorIndex = 6
End If
Next ctlLblCaption
End Sub
'***************************************************************************************************
'***The Label Names and the TextBox Names were made to be identical except for the last part of ***
'***the names which are "Label" and "Text", respectively. This code finds all TextBox Names, ***
'***strips "Text" out of the TexBox Name and replaces it with "Label" which makes it identical ***
'***to the Label Name. Then it searches for the label name in the active sheet. When a match ***
'***found it inserts the TextBox.Text Value (entered by the user) in the cell in row three. ***
'***************************************************************************************************
Private Sub TextBoxText()
Dim ctlTxtBx As control
Dim col As Variant: col = 0
Dim strTextBoxName As String
Dim strShortenedTxtBxName As String
Dim strConvertedTxtBxName As String
For Each ctlTxtBx In WQTR_Form.Controls
If TypeName(ctlTxtBx) = "TextBox" Then
strTextBoxName = ctlTxtBx.Name
strShortenedTxtBxName = Left(strTextBoxName, Len(strTextBoxName) - 4)
strConvertedTxtBxName = strShortenedTxtBxName + "Label"
col = Application.Match(strConvertedTxtBxName, Worksheets(sheetName).Rows(1), 0)
col = CInt(col)
Cells(3, col).Value = ctlTxtBx.Text
End If
Next ctlTxtBx
End Sub
'******************************************************************************************************
'***Search columns from A through DF (110) and deletes columns where the cell in row three is empty.***
'******************************************************************************************************
Private Sub DeleteEmptyColumns()
Dim col As Integer
For col = 110 To 1 Step -1
If Cells(3, col) = "" Then
ActiveSheet.Columns(col).Delete
End If
Next col
End Sub
So, what I would have expected based on Tab order, is the following
'| welderNameLabel | testDateLabel | wqtrNumberLabel | shopLabel | companyNameLabel | revisionNumberLabel | wpsNumberLabel | bm1_specificationLabel |
'|---------------- | ------------- | --------------- | --------- | ---------------- | ------------------- | -------------- | ---------------------- |
'| Welder Name | Test Date | WQTR Number | Shop | Company Name | Revision Number | WPS Number | Specification |
'|---------------- | ------------- | --------------- | --------- | ---------------- | ------------------- | -------------- | ---------------------- |
'| Dean Marin | 5-23-2017 | DM-1234-6G-FCAW | Bravo | ABC Company | Rev. 0 | 12345 | AWS D1.1 Code |
What I actually get is like this:
'| testDateLabel | welderNameLabel | companyNameLabel | shopLabel | wqtrNumberLabel | revisionNumberLabel | wpsNumberLabel | bm1_specificationLabel |
'| ------------- | --------------- | ---------------- | --------- | --------------- | ------------------- | -------------- | ---------------------- |
'| Test Date | Welder Name | Company Name | Shop | WQTR Number | Revision Number | WPS Number | Specification |
'| ------------- | --------------- | ---------------- | --------- | --------------- | ------------------- | -------------- | ---------------------- |
'| 5-23-2017 | Dean Marin | ABC Company | Bravo | DM-1234-6G-FCAW | Rev. 0 | 12345 | AWS D1.1 Code |
I have tested this many many times and it always puts the data in the worksheet in the exact same order. I could write some code to sort it the order I want but before I do that I wanted to post this question to see if anyone has any ideas about why it behaves this way. I am a bit concerned that I will write something to sort the columns and then later find that my experiments were misleading and the order of the data entry really is more random than it appears.
I code have simply written a line of code for every TextBox in the User Form and explicitly specified the exact cell where the data should go, but I wanted something more general I could adapt in other workbooks which I have planned, as they are all related to each other - (Welding Procedures, Procedure Qualifications and Welder Qualification Continuity Logs).
Perhaps there is some method someone knows of controlling this this order before the data is entered rather than doing some kind of sorting operations after the fact?
I appreciate any responses.
UPDATE and ANSWER
I agree with jsotola that it has to be they are ordered in accordance with the order they were created. jsotola provided some code to list the order and I ran it multiple times and always got the exact same list in the exact same order.
Mystery solved!
If you are interested, here is the list. Part of the reason I agree so strongly with the answer is that, from memory, I can say this is the order I added the controls to the form. If you skim the controls you will see that there is a logical grouping of the names. They are related to each other as you read down the list.
bm1_tubeSizeText
bm1_pipeFrame
bm1_pipeDiameterLabel
bm1_pipeDiameterText
baseMetalFrame2
bm2_baseMetalListBox
bm2_specificationLabel
bm2_specificationText
bm2_awsGroupNumberText
bm2_awsGroupNumberLabel
bm2_gradeLabel
bm2_gradeText
bm2_plateFrame
bm2_plateThicknessLabel
bm2_plateThicknessText
bm2_tubeFrame
bm2_tubeWallThicknessLabel
bm2_tubeWallThicknessText
bm2_tubeSizeLabel
bm2_tubeSizeText
bm2_pipeFrame
bm2_pipeSizeLabel
bm2_pipeSizeText
bm2_pipeSheduleLabel
bm2_pipeSheduleText
bm2_pipeDiameterLabel
bm2_pipeDiameterText
actualTestValuesFrame
atv_TypeOfWeldJointText
atv_filletPipeDiameterText
atv_filletPipeDiameterLabel
atv_baseMetalLabel
atv_baseMetalText
atv_filletFrame
atv_filletPipeTubeThicknessLabel
atv_filletPipeTubeThicknessText
atv_filletPlateThicknessLabel
atv_filletPlateThicknessText
atv_weldingFrame
atv_processLabel
atv_processText
atv_TypeOfWeldJointLabel
atv_grooveFrame
atv_groovePipeTubeThicknessLabel
atv_groovePipeTubeThicknessText
atv_groovePlateThicknessLabel
atv_groovePlateThicknessText
atv_groovePipeDiameterLabel
atv_groovePipeDiameterText
atv_processTypeLabel
atv_processTypeText
atv_backingLabel
atv_backingText
atv_weldingProcessFrame
atv_InstructionLabel_1
atv_InstructionLabel_2
atv_fillerMetalFrame
atv_awsSpecLabel
atv_awsSpecText
atv_awsClassificationLabel
atv_awsClassificationText
atv_fNumberLabel
atv_fNumberText
atv_positionFrame
atv_positionWeldedLabel
atv_positionWeldedText
rq_transferModeLabel
rq_transferModeText
rq_progressionLabel
rq_progressionText
atv_InstructionLabel_3
rq_InstructionLabel_4
rq_InstructionLabel_5
rq_singleOrMultipleElectrodesLabel
rq_singleOrMultipleElectrodesText
rq_gasFluxTypeLabel
rq_gasFluxTypeText
rangesQualiifedFrame
rq_weldingFrame
rq_weldingProcessFrame
rq_processLabel
rq_processText
rq_processTypeLabel
rq_processTypeText
rq_backingLabel
rq_backingText
rq_InstructionLabel_1
rq_InstructionLabel_2
rq_fillerMetalFrame
rq_awsSpecLabel
rq_awsSpecText
rq_awsClassificationLabel
rq_awsClassificationText
rq_fNumberLabel
rq_fNumberText
rq_positionFrame
rq_groovePipe24DownLabel
rq_groovePipe24DownText
rq_groovePlatePipe24UpLabel
rq_groovePlatePipe24UpText
rq_filletPlatePipe24UpLabel
rq_filletPlatePipe24UpText
rq_filletPipe24DownLabel
rq_filletPipe24DownText
rq_TypeOfWeldJointLabel
rq_TypeOfWeldJointText
rq_baseMetalLabel
rq_baseMetalText
rq_filletFrame
rq_filletPipeTubeThicknessLabel
rq_filletPipeTubeThicknessText
rq_filletPlateThicknessLabel
rq_filletPlateThicknessText
rq_filletPipeDiameterLabel
rq_filletPipeDiameterText
rq_grooveFrame
rq_groovePipeTubeThicknessLabel
rq_groovePipeTubeThicknessText
rq_groovePlateThicknessLabel
rq_groovePlateThicknessText
rq_groovePipeDiameterLabel
rq_groovePipeDiameterText
atv_gasFluxTypeText
atv_transferModeLabel
atv_transferModeText
atv_progressionLabel
atv_progressionText
atv_InstructionLabel_4
atv_InstructionLabel_5
atv_singleOrMultipleElectrodesLabel
atv_singleOrMultipleElectrodesText
atv_gasFluxTypeLabel
testResultsFrame
acceptanceCriteria_1Label
acceptanceCriteria_1Text
typeOfTest_1Label
typeOfTest_1Text
results_1Label
results_1Text
remarks_1Label
remarks_1Text
acceptanceCriteria_3Text
typeOfTest_3Text
results_3Text
remarks_3Text
acceptanceCriteria_2Text
typeOfTest_2Text
results_2Text
remarks_2Text
acceptanceCriteria_4Text
typeOfTest_4Text
results_4Text
remarks_4Text
acceptanceCriteria_5Text
typeOfTest_5Text
results_5Text
remarks_5Text
certificationFrame
laboratoryLabel
laboratoryText
testConductedByLabel
testNumberLabel
testNumberText
fileNumberLabel
fileNumberText
certStatementLabel_1
codeYearText
certStatementLabel_2
certStatementLabel_3
manufacturerOrContractorLabel
manufacturerOrContractorText
authorizedByLabel
authorizedByText
dateLabel
dateText
finishFrame
finishInstructionsLabel
saveProgressButton
rq_positionsQualifiedFrame
testConductedByText
AbortButton
typeOfTest_2Label
acceptanceCriteria_2Label
results_2Label
remarks_2Label
typeOfTest_3Label
typeOfTest_4Label
typeOfTest_5Label
acceptanceCriteria_3Label
acceptanceCriteria_4Label
acceptanceCriteria_5Label
results_3Label
results_4Label
results_5Label
remarks_3Label
remarks_4Label
remarks_5Label
WelderIDLabel
WelderIDText
this will show the order-of-creation of the form controls
Private Sub UserForm_Click() ' runs when form background is clicked
Stop ' put here so that the code window shows up ( press F8 or F5 to continue)
Dim i As Integer
For i = 0 To UserForm1.Controls.Count - 1
Debug.Print UserForm1.Controls(i).Name
Next i
stop
End Sub
Related
My Problem:
I have made a For Each loop, which Loops through 2 different columns in the same sheet.
This loop copies the desired columns, and the unique values.
Althought the macro works, it will paste a wrong date.
How it pastes a wrong date, is specified under the section "Goal:".
My Table:
| Date | ColB | Amount | Date | ColG | Amount |
| 02-08-2018 | V584753 | 500 | 02-08-2018 | V584753 | -500 |
| 11-08-2018 | 486542 | 1.000 | 21-08-2018 | 439857 | -30.547 |
| 21-08-2018 | 439857 | 30.547 | 31-08-2018 | V587742 | -1.059 |
My Code:
Sub PasteCellsWithoutMatch()
Dim ColB As Range, ColG As Range, c As Range
Dim Wf As WorksheetFunction
Set Wf = WorksheetFunction
Dim vR() As Variant
Dim k As Long, j As Integer
For Each c In ColB.Cells
If Not IsEmpty(c) Then
With Wf
n = .CountIfs(ColG, c)
If n = 0 Then
k = k + 1
ReDim Preserve vR(1 To 3, 1 To k)
For j = 1 To 3
vR(j, k) = c.Offset(0, j - 2)
Next j
End If
End With
End If
Next
Sheet("Match").Range("A1").Resize(k, 3) = Wf.Transpose(vR)
Goal:
What I mean by "pasting the wrong date", the code will swaps the "dd-mm-yyyy" to "mm-dd-yyyy" whenever the first value is below 12.
Meaning that: 02-08-2018
Becomes: 08-02-2018
Whereas: 13-08-2018
Remains: 13-08-2018
How can I correct this error?
If there is any correction to it.
Thank you in advance, for your help.
Replicating the problem with minimal code:
Public Sub TestMe()
Dim val1 As String: val1 = "02/08/2018"
Dim val2 As String: val2 = "13/08/2018"
Dim myInput1 As Date
Dim myInput2 As Date
myInput1 = val1
myInput2 = val2
Range("A1") = myInput1
Range("A2") = myInput2
End Sub
Gets this:
One possible solution is using DateSerial():
Public Sub TestMe()
Dim val1 As String: val1 = "02/08/2018"
Dim val2 As String: val2 = "13/08/2018"
Dim myInput1 As Date
Dim myInput2 As Date
myInput1 = DateSerial(Split(val1, "/")(2), Split(val1, "/")(1), Split(val1, "/")(0))
myInput2 = DateSerial(Split(val2, "/")(2), Split(val2, "/")(1), Split(val2, "/")(0))
Range("A1") = myInput1
Range("A2") = myInput2
End Sub
For some advanced solution, you may consider either writing a customized function or changing a bit the regional settings. The latter is dangerous.
It depends on your local settings. Anyway, macro doesn't look into local at all.
So you can overpass it by using format function.
For example:
val1="02/08/2018"
val2=format(cdate(val1),"ddmmyyyy"))
It's gonna work
I found a solution myself.
First of all, thank you for you efforts, but I couldn't really get myself to try them, since I needed to change to much in my formula...
Before looping through the cells, I removed the date format from the date columns.
Whereas turning it into to general, the transpose won't swap the numbers around.
RngNavRange = "A3:A" & LastRowA
RngKvikRange = "F3:F" & LastRowF
Range(RngNavRange).NumberFormat = "General"
Range(RngKvikRange).NumberFormat = "General"
I have a gnarly amount of data across many sheets in LibreOffice -- an ADDRESS column and a DATA column -- and I'd like to count the number of times each address occurs, put into a NUM_ADDR column. E.g.:
ADDR | DATA | NUM_ADDR
00000000bbfe22d0 | 876d4eb163886d4e | 1
00000000b9dfffd0 | 4661bada6d4661ba | 1
00000000b9dfc3d0 | 5d4b40b4705d4b40 | 1
00000000b9def7d0 | 8f8570a5808f8570 | 1
00000000b9de17d0 | 63876d4eb163886d | 1
00000000b9dddfd0 | 6d4eb163886d4eb1 | 3
00000000b9dddfd0 | 705d4b40b4705d4b |
00000000b9dddfd0 | b4705d4b40b4705d |
00000000b7df83d0 | 40b4705d4b40b470 | 1
00000000b7d607d0 | 705d4b40b4705d4b | 1
...
When doing things manually I used the COUNTIF function on each address, but I've found that a macro would save time in the long run. Here's a snippet of what I have so far, given that a previous function has already determined the length (number of rows) of the data, stored in RowCounter:
Dim CountedAddr(RowCounter, RowCounter) as String
Dim CountedAddrPtr as Integer
Dim CurrentCell as Object
Dim i as Integer
CountedAddrPtr = 0
' Populate CountedAddr array
For i = 1 to RowCounter-1
CurrentCell = CurrentSheet.getCellByPosition(0, i)
If Not CurrentCell.String In CountedAddr(?) Then
CurrentSheet.getCellByPosition(2, i).Value = 1 ' for debugging
CountedAddr(CountedAddrPtr, 0) = CurrentCell.String
CountedAddrPtr = CountedAddrPtr + 1
Else
CurrentSheet.getCellByPosition(2, i).Value = 0 ' for debugging
EndIf
Next
' For each unique address, count number of occurances
For i = 0 to UBound(CountedAddr())
For j = 1 to RowCounter-1
If CurrentSheet.getCellByPosition(0, j).String = CountedAddr(i, 0) Then
CountedAddr(i, 1) = CountedAddr(i, 1)+1
EndIf
Next
Next
' Another function to populate NUM_ADDR from CountedAddr array...
So my first question is: how can we determine if an element (the address in the current cell) is in the CountedAddr array (see the (?) above)? Second, is there a much more efficient way to achieve the second block of code? Unfortunately sorting is out of the question, since the chronology of the addresses and data form something of a time base. Third, is the whole shebang a foolish way to attack this problem?
Many thanks from a hardware dood on a software task!
Dictionary-type objects such as a VB6 Collection are efficient for looking up items, because it finds the key directly rather than looping through a long array. Our countedAddrs collection below will store a count for each address.
Sub CountAddrs
Dim countedAddrs As New Collection
Dim oCurrentSheet As Object
Dim oCurrentCell As Object
Dim currentAddr As String
Dim i As Integer
Dim newCount As Integer
Dim rowCounter As Integer
Const ADDR_COL = 0
Const COUNT_COL = 2
oCurrentSheet = ThisComponent.CurrentController.ActiveSheet
rowCounter = 11
' Populate countedAddrs array.
For i = 1 to rowCounter - 1
oCurrentCell = oCurrentSheet.getCellByPosition(ADDR_COL, i)
currentAddr = oCurrentCell.String
If Contains(countedAddrs, currentAddr) Then
' Increment the count.
newCount = countedAddrs.Item(currentAddr) + 1
countedAddrs.Remove(currentAddr)
countedAddrs.Add(newCount, currentAddr)
oCurrentSheet.getCellByPosition(COUNT_COL, i).Value = newCount ' for debugging
Else
countedAddrs.Add(1, currentAddr)
oCurrentSheet.getCellByPosition(COUNT_COL, i).Value = 1 ' for debugging
EndIf
Next
End Sub
This code requires the following helper function. In most languages, dictionary objects have this functionality built-in, but Basic is rather simplistic.
' Returns True if the collection contains the key, otherwise False.
Function Contains(coll As Collection, key As Variant)
On Error Goto ErrorHandler
coll.Item(key)
Contains = True
Exit Function
ErrorHandler:
Contains = False
End Function
I need to validate user input on when cells change and show the error in another cell in Excel using VBA.
I run into problems where my validator is called on all cells in the sheet when a user inserts rows or column which makes Excel unresponsive for a long time, how can I fix this?
Below are my requirements and my current solution with full documentation.
Definition and requirements
Consider the following table:
Example User Input Table
| | | Tolerance | | |
| Type | Length | enabled | Tolerance | Note |
|------|--------|-----------|-----------|----------------------------|
| | 4 | 0 | | Type is missing |
| | | 0 | | Type is missing |
| C | 40 | 1 | 110 | |
| D | 50 | 1 | | Tolerance is missing |
| | | | | |
The idea is that the user inputs values in the table, once a value has been changed (the user leaves the cell) the value is validated and if there is a problem the error is printed in the Note column.
Blank lines should be ignored.
I need this to be robust meaning it should not fail on any user input, that means it has to work for the following cases:
Paste values
Delete rows
Insert rows (empty or cut cells)
Insert/delete columns *
Any other case I missed thinking about?
*It is OK if the the validation fails when a user is deleting a column that is part of the table as this is seen as the user willfully vandalizing the sheet, but it has to fail gracefully (i.e. not by validating all cells in the worksheet which takes a long time). It would have been great if this action was undoable, however my current understanding of Excel suggests this is impossible (after a macro has changed something in the sheet, nothing can be undone anymore).
The Note cell can only contain one error at a time, for the user the most relevant error is the one for the cell the user last changed, so it should display this error first. After the user fixes that error the order is not that important anymore, so it could just display the errors from left to right.
Problems with current approach
My problem is that when rows/columns are inserted validation is triggered for all cells in the sheet which is a very slow process and to the user it looks like the program has crashed, but it will return once the validation is complete.
I don't know why Excel does this but I need a way to work around it.
Code placed in a Sheet named 'User Input'
My solution is based on the only on change event handler I know of: the per sheet global Worksheet_Change function (ugh!).
Worksheet_Change function
First it checks if the changed cell(s) intersects with the cells I'm interested in validating. This check is actually quite fast.
OldRowCount here is a try to catch the user inserting or deleting cells depending on how the used range changes, however this only solves some cases and introduces problems whenever Excel forgets the global variable (which happens now and then for as to me unknown reasons) as well as the first time the function is run.
The for loop makes it work for pasted values.
Option Explicit
Public OldRowCount As Long
' Run every time something is changed in the User Input sheet, it then filters on actions in the table
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRowCount As Long
NewRowCount = ActiveSheet.UsedRange.Rows.count
If OldRowCount = NewRowCount Then
If Not Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE)) Is Nothing Then
Dim myCell As Range
' This loop makes it work if multiple cells are changed, for example while pasting cells
For Each myCell In Target.Cells
' Protect the header rows
If myCell.row >= ROW_FIRST Then
checkInput_cell myCell.row, myCell.Column, Me
End If
Next
End If
ElseIf OldRowCount > NewRowCount Then
'Row deleted, won't have to deal with this as it solves itself
OldRowCount = NewRowCount
ElseIf OldRowCount < NewRowCount Then
Debug.Print "Row added, TODO: deal with this"
OldRowCount = NewRowCount
End If
End Sub
Code placed in a module
Global variables
Defines the rows/columns to be validated.
Option Explicit
' User input sheet set up
Public Const ROW_FIRST = 8
Public Const COL_TYPE = "B"
Public Const COL_LENGTH = "C"
Public Const COL_TOLERANCE_ENABLED = "D"
Public Const COL_TOLERANCE = "E"
Public Const COL_NOTE = "G"
Cell checking function
This function validates the given cell unless the row where the cell is is empty.
Meaning we are only interested in validating cells on rows where the user has actually started giving values. Blank rows is not a problem.
It first validates the currently changed cell, if it is OK it will then validate the other cells on the given row (since some cells validation depends the values of other cells, see Tolerance enabled in my example table above).
The note will only ever contain one error message at a time, the above is done so that we always get the error of the last changed cell in the Note cell.
Yes, this will make the checker run twice on the current cell, while it is not a problem it could be avoided by a more complex if statement, but for simplicity I skipped it.
Sub checkInput_cell(thisRow As Long, thisCol As Long, sheet As Worksheet)
Dim note As String
note = ""
With sheet
' Ignore blank lines
If .Range(COL_TYPE & thisRow).value <> "" _
Or .Range(COL_LENGTH & thisRow).value <> "" _
Or .Range(COL_TOLERANCE_ENABLED & thisRow).value <> "" _
Or .Range(COL_TOLERANCE & thisRow).value <> "" _
Then
' First check the column the user changed
If col2Let(thisCol) = COL_TYPE Then
note = check_type(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_LENGTH Then
note = check_length(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_TOLERANCE_ENABLED Then
note = check_tolerance_enabled(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_TOLERANCE Then
note = check_tolerance(thisRow, sheet)
End If
' If that did not result in an error, check the others
If note = "" Then note = check_type(thisRow, sheet)
If note = "" Then note = check_length(thisRow, sheet)
If note = "" Then note = check_tolerance_enabled(thisRow, sheet)
If note = "" Then note = check_tolerance(thisRow, sheet)
End If
' Set note string (done outside the if blank lines checker so that it will reset the note to nothing on blank lines)
' only change it actually set it if it has changed (optimization)
If Not .Range(COL_NOTE & thisRow).value = note Then
.Range(COL_NOTE & thisRow).value = note
End If
End With
End Sub
Validators for individual columns
These functions takes a row and validate the a certain column according to it's special requirements. Returns a string if the validation fails.
' Makes sure that type is :
' Unique in its column
' Not empty
Function check_type(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
Dim duplicate_found As Boolean
Dim lastRow As Long
Dim i As Long
duplicate_found = False
value = sheet.Range(COL_TYPE & affectedRow).value
check_type = ""
' Empty value check
If value = "" Then
check_type = "Type is missing"
Else
' Check for uniqueness
lastRow = sheet.Range(COL_TYPE & sheet.Rows.count).End(xlUp).row
If lastRow > ROW_FIRST Then
For i = ROW_FIRST To lastRow
If Not i = affectedRow And sheet.Range(COL_TYPE & i).value = value Then
duplicate_found = True
End If
Next
End If
If duplicate_found Then
check_type = "Type has to be unique"
Else
' OK
End If
End If
End Function
' Makes sure that length is a whole number larger than -1
Function check_length(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_LENGTH & affectedRow).value
check_length = ""
If value = "" Then
check_length = "Length is missing"
ElseIf IsNumeric(value) Then
If Not Int(value) = value Then
check_length = "Length cannot be decimal"
ElseIf value < 0 Then
check_length = "Length is below 0"
ElseIf InStr(1, value, ".") > 0 Then
check_length = "Length contains a dot"
Else
' OK
End If
ElseIf Not IsNumeric(value) Then
check_length = "Length is not a number"
End If
End Function
' Makes sure that tolerance enabled is either 1 or 0:
Function check_tolerance_enabled(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value
check_tolerance_enabled = ""
If Not value = "0" And Not value = "1" Then
check_tolerance_enabled = "Tolerance enabled has to be 1 or 0"
Else
' OK
End If
End Function
' Makes sure that tolerance is a whole number larger than -1
' But only checks tolerance if it is enabled in the tolerance enabled column
Function check_tolerance(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_TOLERANCE & affectedRow).value
check_tolerance = ""
If value = "" Then
If sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value = 1 Then
check_tolerance = "Tolerance is missing"
End If
ElseIf IsNumeric(value) Then
If Not Int(value) = value Then
check_tolerance = "Tolerance cannot be decimal"
ElseIf value < 0 Then
check_tolerance = "Tolerance is below 0"
ElseIf InStr(1, value, ".") > 0 Then
check_tolerance = "Tolerance contains a dot"
Else
' OK
End If
ElseIf Not IsNumeric(value) Then
check_tolerance = "Tolerance is not a number"
End If
End Function
Addressing support functions
These functions translates a letter to a column and vice versa.
Function let2Col(colStr As String) As Long
let2Col = Range(colStr & 1).Column
End Function
Function col2Let(iCol As Long) As String
Dim iAlpha As Long
Dim iRemainder As Long
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
col2Let = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
col2Let = col2Let & Chr(iRemainder + 64)
End If
End Function
Code is tested on/has to work for Excel 2010 and onwards.
Edited for clarity
Finally got it working
After quite a bit of more agonizing, it turned out the fix was quite easy.
I added a new test that checks if the area that the user changed (the Target Range) consists of a column by looking at the address of the Range, if it is a full column the checker will ignore it. This solves the problem where the validation hogs Excel for about one minute.
The result of the intersection calculation is used for the inner loop which limits checks to cells within the area we are interested in validating.
Fixed Worksheet_Change function
Option Explicit
' Run every time something is changed in the User Input sheet
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InterestingRange As Range
Set InterestingRange = Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE))
If Not InterestingRange Is Nothing Then
' Guard against validating every cell in an inserted column
If Not RangeAddressRepresentsColumn(InterestingRange.address) Then
Dim myCell As Range
' This loop makes it work if multiple cells are changed,
' for example when pasting cells
For Each myCell In InterestingRange.Cells
' Protect the header rows
If myCell.row >= ROW_FIRST Then
checkInput_cell myCell.row, myCell.Column, Me
End If
Next
End If
End If
End Sub
New support function
' Takes an address string as input and determines if it represents a full column
' A full column is on the form $A:$A for single or $A:$C for multiple columns
' The unique characteristic of a column address is that it has always two
' dollar signs and one colon
Public Function RangeAddressRepresentsColumn(address As String) As Integer
Dim dollarSignCount As Integer
Dim hasColon As Boolean
Dim Counter As Integer
hasColon = False
dollarSignCount = 0
' Loop through each character in the string
For Counter = 1 To Len(address)
If Mid(address, Counter, 1) = "$" Then
dollarSignCount = dollarSignCount + 1
ElseIf Mid(address, Counter, 1) = ":" Then
hasColon = True
End If
Next
If hasColon And dollarSignCount = 2 Then
RangeAddressRepresentsColumn = True
Else
RangeAddressRepresentsColumn = False
End If
End Function
I've got a combobox on a userform. This combobox exists out of four columns. This is an example of the data in the userform:
Week 1: | 01-01-2015 | - | 07-01-2015
Week 2: | 08-01-2015 | - | 14-01-2015
Week 3: | 15-01-2015 | - | 21-01-2015
Now, when I select one of the options, for example week 2, my selection of the combobox will change to Week 2:, while I want it to change to Week 2: | 08-01-2015 | - | 14-01-2015
I know I actually should use listboxes for these kind of things, but I don't like the looks of a listbox.
You can try this. However, be aware that after you change the text to the "mixed string", you will no longer be able to retrieve the selected ListIndex
Private Sub ComboBox5_Change()
Dim i As Integer
With ComboBox5
i = .ListIndex: If i < 0 Then Exit Sub
.Text = .List(i, 0) & " | " & .List(i, 1) & " | " & .List(i, 2) & " | " & .List(i, 3)
End With
End Sub
Good Morning,
I am considerable new to VBA and was looking for some assistance on writing an auto-filter code for my table.
Tariffs | SME100 | Enterprise | CustomerLoyalty | AccountManage
------------+-----------+---------------+-------------------+-------------------
Voda Red | 1 | 1 | 0 | 1
Voda 1G D | 1 | 0 | 1 | 0
1* eligible to sell
0* not eligible sell
I am trying to write a code that takes the value from a validation box ("B2") and automatically filters the specific column of that sales channel for the eligible tariffs. My current code is:
Sub Filter()
Dim strRange As String
strRange = "B"
Dim b As Integer
b = "2"
Range = ActiveSheet.Cells(2, 2).Address(False, False)
If Range = True And Range = "SME100" Then
ActiveSheet.ListObjects("TariffTable").Range.AutoFilter Field:=2, Criteria1:="1"
If Range = True And Range = "Enterprise" Then
ActiveSheet.ListObjects("TariffTable").Range.AutoFilter Field:=3, Criteria1:="1"
If Range = True And Range = "CustomerLoyalty" Then
ActiveSheet.ListObjects("TariffTable").Range.AutoFilter Field:=4, Criteria1:="1"
If Range = True And Range = "AccountManagement" Then
ActiveSheet.ListObjects("TariffTable").Range.AutoFilter Field:=5, Criteria1:="1"
Else
MsgBox ("No Sales Channel Selected")
End If
End Sub
Any advise will be much appreciated
I would approach it in a different way:
Sub Filter()
Dim columnNumber, tableRow, tableColumn, tableWidth As Integer
Dim tableName, columnName As String
tableName = "Table1"
columnName = ActiveSheet.range("B2").Value
'This clears the existing filter
ActiveSheet.ListObjects(tableName).range.AutoFilter
'Assign some numbers we need to know about the table to check the headers
tableRow = ActiveSheet.ListObjects(tableName).range.Row
tableColumn = ActiveSheet.ListObjects(tableName).range.Column
tableWidth = ActiveSheet.ListObjects(tableName).range.Columns.Count
'If a column title with the specified value does not exist VBA throws an error which we need to catch, this is one of the many reasons I dislike VBA :D
On Error GoTo ErrorHandler
'Search through the table column header row to find the specified column and assign the number to columnNumber
columnNumber = Application.WorksheetFunction.Match(columnName, range(Cells(tableRow, tableColumn), Cells(tableRow, tableColumn + tableWidth)), 0)
'Apply the filter "1" to the found columnNumber
ActiveSheet.ListObjects(tableName).range.AutoFilter Field:=columnNumber, Criteria1:="1"
'Exit the sub otherwise the "error handling" will be provoked
Exit Sub
ErrorHandler:
MsgBox columnName & " does not exist"
End Sub
Edit: Plus you should read and understand sancho.s's answer.
I suggest modifications, checks, etc.:
You probably need Range = ActiveSheet.Cells(2, 2).Text (or using a different name, see below). This is likely the source of error. Plus, there is a lot to improve in your code.
Use Dim colstr as String, colstr = ... instead of Range = ....
Make sure TariffTable is correctly defined.
AccountManagement should read AccountManage.
Make sure ActiveSheet refers to the Sheet you want to work with.
Inquire If colstr = "Enterprise" Then instead of If colstr = True And colstr = "Enterprise" Then (already using a changed name).
You can improve over using multiple Ifs, e.g., with Select Case, or even matching colstr against the Range containing the headings.
PS: You did not post the output/errors of your code.