dmqueen
Board Regular
- Joined
- Aug 5, 2014
- Messages
- 53
Hello,
I have diligently trying to write a VBA program that guides user input from column to column in a worksheet, verifying that an entry was made. It begins by inserting a new row for entry and generating a par number base sequentially on the last entry- this works! )
Then t should allow freeform entry into open columns, selections when there is a listbox. - this doesn't .
I've tried calling an inputbox subroutine, and typing directly into the sheet. All I want to do is verify that an entry was made for every column, except Notes, which can be blank. If I rip out any more hair I'll be bald.
I've got Intermediate exp. doing this, but obviously not enough. I don't want to leave these people hanging, please help!
All my code is below. The file has multiple worksheets with similar info., but varying columns, both info and number.
<code>
'Written By: Dawn Queen
'For: Tools For Bending
'On: August 15, 2014
'Contact: dmcole@mail.com
'Purpose: Guide Input for Engineers and track Parts Created for Clients
'Converted Historical Lotus file and rewrote and updated scripting
Option Explicit
Private Sub Workbook_Activate()
Application.MoveAfterReturnDirection = xlToRight
End Sub
Sub MyCaller()
Dim rngV As Range, rngR As Range
Set rngV = Range("A1:A10")
Set rngR = Range("B1:B10")
Call CalledProc(rngVal:=rngV, rngRef:=rngR)
MsgBox "RngV: " & rngV.Address & vbCr & _
"RngR: " & rngR.Address
End Sub
Sub CalledProc(ByVal rngVal As Range, ByRef rngRef As Range)
rngVal.Interior.Color = vbYellow
rngRef.Interior.Color = vbRed
Set rngVal = Range("A11:A20")
Set rngRef = Range("B11:B20")
End Sub
Public Sub fInputPart()
'col A
'add a new row
'get last PartNo.
'add 1
'generate new part no.
'CurrentWorksheet.Activate()
ActiveSheet.Range("A1").Select
'goto the top, and cycle down each line until you find the top of the entries, "="
'goto the top entry ready to insert the new entry
While ActiveCell.Value <> "="
ActiveCell.Offset(1, 0).Activate
Wend
'OK, we found the top of the entries
'Don't overwrite the =, go below
ActiveCell.Offset(1, 0).Activate
'insert the new entry row
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
'note where we are
Dim NewRowNum As Integer
NewRowNum = ActiveCell.Row
'Application defined or object defined error 1004
'Problem with line below!!
'Range("A" & ActiveCell.Row).Select
'Goto last part number entry
'Get the last part number here!!
Application.ActiveCell.Offset(1, 0).Activate
Dim LastPartNO As Integer
'Put the new part number here!!
Dim NewPartNo As String
NewPartNo = FgenerateNextPartNumber(Application.ActiveCell.Value)
Range("A" & NewRowNum).Value = NewPartNo
'debugging
'Call MsgBox("NewPartNo is: " & NewPartNo)
'Call MsgBox("Row Num 2 insert Part Num @ is: " & NewRowNum)
'this next line is VITAL or it will hang INDEFINETLY!
Application.Range("A" & NewRowNum).Value = NewPartNo
'go to next col
'col B
'verify entry was made
'go to next col
'while there are columns for data entry (has column title) verify entry was made in last column,
'error msg if not,
'go to next column if made
'Part Number in- goto next column and start loop
'If we've moved off target row, move back to it!
Application.ActiveCell.Offset(0, 1).Activate
If ActiveCell.Row <> NewRowNum Then
Application.ActiveCell.Offset(-1, 0).Activate
'Application.ActiveCell.Row() = NewRowNum
'Application.ActiveCell.Column & NewRowNum.Activate()
End If
'KEEP While loop LINE BREAKPOINTED UNTIL INPUT LOOP WORKING!!
'/******************************************************************************
'While the column is empty, and not NOTES there should be an entry/selection or we cannot continue.
'accept value entries & copy listbox selections 2 columns!!
While (NewRowNum & Application.ActiveCell.Column <> "")
'fGetInput(NewRowNum,ActiveCell.Column)
'When Enter key hit, ck that value entered and goto next column
'On KeypressByVal(KeyAscii As MSForms.ReturnInteger)
'If KeyAscii = 13 Then
'Application.ActiveCell.Value =
'while there are columns left for entry: there is a column header
'go to the next column for entry that is active and has a width not equal to 1
'verify entry was made in last column: holler and stop if not: continue if made
'blank allowed only for "NOTES" column!
'/******************************************************************************
'REVISE THIS TO SEARCH FROM TOP ROW, DON'T ASSUME IT'LL BE ON ROW 6!
If ActiveCell.Offset(0, 1) = Null Then
Range(ActiveCell.Column & "6").Select
If (ActiveCell.Value()) <> "NOTES" Then
Call MsgBox(" Please enter/select a value in the previous column!", vbCritical, Application.Name)
Else
'if inactive(width=1, jump it, else goto next column and stop for entry
If ActiveCell.Offset(0, 1).ColumnWidth = 1 Then
ActiveCell.Offset(0, 2).Activate
Else: ActiveCell.Offset(0, 1).Activate
End If
End If
End If
'End If
Wend
Call MsgBox("Entry Complete, thank you! Don't forget to save when done! ", vbInformation, Application.Name)
End Sub
Public Function FgenerateNextPartNumber(LastPartIn As String) As String
Dim LastPartNO As String
LastPartNO = LastPartIn
'LastPartNo = ActiveCell.Value
Dim NewStrPartNo As String
Dim strseparator As String
Dim strPartNo As String
Dim strLastPartNo As String
strPartNo = ActiveSheet.Name()
Dim strTrimWksName As String
'Pull part number from worksheet name
strTrimWksName = Left(strPartNo, 3)
strPartNo = strTrimWksName
Dim strSeperator As String
'/*****************************************************
'adjust to keep leading zeros!
'& accomodate longer part numbers-at least 5 digits!
strLastPartNo = Right(LastPartIn, 4)
Dim strNewSeqPartNo As String
Dim intNewSeqNo As Integer
Dim intLastSeqNo As Integer
Dim lastseqNo As Integer
'debugging
'Call MsgBox("strLastPartNo: " & strLastPartNo)
Dim tempConvert As Integer
tempConvert = CInt(strLastPartNo)
intLastSeqNo = tempConvert
intNewSeqNo = intLastSeqNo + 1
'if leading zero, put it back in
If Left(intLastSeqNo, 4) = "0" Then
intNewSeqNo = "0" & intNewSeqNo
End If
'handle special case separators HERE!
'debugging
'Call MsgBox("Generating Part Number! Last Part No. was " & intLastSeqNo)
If strPartNo = "180" Or strPartNo = "300" Or strPartNo = "310" Or strPartNo = "320" Or strPartNo = "330" Or strPartNo = "970" Or strPartNo = "681" Or strPartNo = "981" Then
strseparator = "-1-"
Else: strseparator = "-0-"
End If
'put in return stmt 4 compiler
NewStrPartNo = strPartNo + strseparator + "0" + CStr(intNewSeqNo)
NewStrPartNo = strPartNo + strseparator + CStr(intNewSeqNo)
'return statement
FgenerateNextPartNumber = NewStrPartNo
End Function
'Sub fgetInput(WhereRow, WhereCol)
'Dim target As String
'Dim myRange As Range
'Set Range = WhereRow,WhereCol
'target = InputBox("Enter Cell Value")
'Range(myRange).Select
'Range(myRange) = target
'End Sub
</code>
Please feel free to comment on my coding as well.
I have diligently trying to write a VBA program that guides user input from column to column in a worksheet, verifying that an entry was made. It begins by inserting a new row for entry and generating a par number base sequentially on the last entry- this works! )
Then t should allow freeform entry into open columns, selections when there is a listbox. - this doesn't .
I've tried calling an inputbox subroutine, and typing directly into the sheet. All I want to do is verify that an entry was made for every column, except Notes, which can be blank. If I rip out any more hair I'll be bald.
I've got Intermediate exp. doing this, but obviously not enough. I don't want to leave these people hanging, please help!
All my code is below. The file has multiple worksheets with similar info., but varying columns, both info and number.
<code>
'Written By: Dawn Queen
'For: Tools For Bending
'On: August 15, 2014
'Contact: dmcole@mail.com
'Purpose: Guide Input for Engineers and track Parts Created for Clients
'Converted Historical Lotus file and rewrote and updated scripting
Option Explicit
Private Sub Workbook_Activate()
Application.MoveAfterReturnDirection = xlToRight
End Sub
Sub MyCaller()
Dim rngV As Range, rngR As Range
Set rngV = Range("A1:A10")
Set rngR = Range("B1:B10")
Call CalledProc(rngVal:=rngV, rngRef:=rngR)
MsgBox "RngV: " & rngV.Address & vbCr & _
"RngR: " & rngR.Address
End Sub
Sub CalledProc(ByVal rngVal As Range, ByRef rngRef As Range)
rngVal.Interior.Color = vbYellow
rngRef.Interior.Color = vbRed
Set rngVal = Range("A11:A20")
Set rngRef = Range("B11:B20")
End Sub
Public Sub fInputPart()
'col A
'add a new row
'get last PartNo.
'add 1
'generate new part no.
'CurrentWorksheet.Activate()
ActiveSheet.Range("A1").Select
'goto the top, and cycle down each line until you find the top of the entries, "="
'goto the top entry ready to insert the new entry
While ActiveCell.Value <> "="
ActiveCell.Offset(1, 0).Activate
Wend
'OK, we found the top of the entries
'Don't overwrite the =, go below
ActiveCell.Offset(1, 0).Activate
'insert the new entry row
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
'note where we are
Dim NewRowNum As Integer
NewRowNum = ActiveCell.Row
'Application defined or object defined error 1004
'Problem with line below!!
'Range("A" & ActiveCell.Row).Select
'Goto last part number entry
'Get the last part number here!!
Application.ActiveCell.Offset(1, 0).Activate
Dim LastPartNO As Integer
'Put the new part number here!!
Dim NewPartNo As String
NewPartNo = FgenerateNextPartNumber(Application.ActiveCell.Value)
Range("A" & NewRowNum).Value = NewPartNo
'debugging
'Call MsgBox("NewPartNo is: " & NewPartNo)
'Call MsgBox("Row Num 2 insert Part Num @ is: " & NewRowNum)
'this next line is VITAL or it will hang INDEFINETLY!
Application.Range("A" & NewRowNum).Value = NewPartNo
'go to next col
'col B
'verify entry was made
'go to next col
'while there are columns for data entry (has column title) verify entry was made in last column,
'error msg if not,
'go to next column if made
'Part Number in- goto next column and start loop
'If we've moved off target row, move back to it!
Application.ActiveCell.Offset(0, 1).Activate
If ActiveCell.Row <> NewRowNum Then
Application.ActiveCell.Offset(-1, 0).Activate
'Application.ActiveCell.Row() = NewRowNum
'Application.ActiveCell.Column & NewRowNum.Activate()
End If
'KEEP While loop LINE BREAKPOINTED UNTIL INPUT LOOP WORKING!!
'/******************************************************************************
'While the column is empty, and not NOTES there should be an entry/selection or we cannot continue.
'accept value entries & copy listbox selections 2 columns!!
While (NewRowNum & Application.ActiveCell.Column <> "")
'fGetInput(NewRowNum,ActiveCell.Column)
'When Enter key hit, ck that value entered and goto next column
'On KeypressByVal(KeyAscii As MSForms.ReturnInteger)
'If KeyAscii = 13 Then
'Application.ActiveCell.Value =
'while there are columns left for entry: there is a column header
'go to the next column for entry that is active and has a width not equal to 1
'verify entry was made in last column: holler and stop if not: continue if made
'blank allowed only for "NOTES" column!
'/******************************************************************************
'REVISE THIS TO SEARCH FROM TOP ROW, DON'T ASSUME IT'LL BE ON ROW 6!
If ActiveCell.Offset(0, 1) = Null Then
Range(ActiveCell.Column & "6").Select
If (ActiveCell.Value()) <> "NOTES" Then
Call MsgBox(" Please enter/select a value in the previous column!", vbCritical, Application.Name)
Else
'if inactive(width=1, jump it, else goto next column and stop for entry
If ActiveCell.Offset(0, 1).ColumnWidth = 1 Then
ActiveCell.Offset(0, 2).Activate
Else: ActiveCell.Offset(0, 1).Activate
End If
End If
End If
'End If
Wend
Call MsgBox("Entry Complete, thank you! Don't forget to save when done! ", vbInformation, Application.Name)
End Sub
Public Function FgenerateNextPartNumber(LastPartIn As String) As String
Dim LastPartNO As String
LastPartNO = LastPartIn
'LastPartNo = ActiveCell.Value
Dim NewStrPartNo As String
Dim strseparator As String
Dim strPartNo As String
Dim strLastPartNo As String
strPartNo = ActiveSheet.Name()
Dim strTrimWksName As String
'Pull part number from worksheet name
strTrimWksName = Left(strPartNo, 3)
strPartNo = strTrimWksName
Dim strSeperator As String
'/*****************************************************
'adjust to keep leading zeros!
'& accomodate longer part numbers-at least 5 digits!
strLastPartNo = Right(LastPartIn, 4)
Dim strNewSeqPartNo As String
Dim intNewSeqNo As Integer
Dim intLastSeqNo As Integer
Dim lastseqNo As Integer
'debugging
'Call MsgBox("strLastPartNo: " & strLastPartNo)
Dim tempConvert As Integer
tempConvert = CInt(strLastPartNo)
intLastSeqNo = tempConvert
intNewSeqNo = intLastSeqNo + 1
'if leading zero, put it back in
If Left(intLastSeqNo, 4) = "0" Then
intNewSeqNo = "0" & intNewSeqNo
End If
'handle special case separators HERE!
'debugging
'Call MsgBox("Generating Part Number! Last Part No. was " & intLastSeqNo)
If strPartNo = "180" Or strPartNo = "300" Or strPartNo = "310" Or strPartNo = "320" Or strPartNo = "330" Or strPartNo = "970" Or strPartNo = "681" Or strPartNo = "981" Then
strseparator = "-1-"
Else: strseparator = "-0-"
End If
'put in return stmt 4 compiler
NewStrPartNo = strPartNo + strseparator + "0" + CStr(intNewSeqNo)
NewStrPartNo = strPartNo + strseparator + CStr(intNewSeqNo)
'return statement
FgenerateNextPartNumber = NewStrPartNo
End Function
'Sub fgetInput(WhereRow, WhereCol)
'Dim target As String
'Dim myRange As Range
'Set Range = WhereRow,WhereCol
'target = InputBox("Enter Cell Value")
'Range(myRange).Select
'Range(myRange) = target
'End Sub
</code>
Please feel free to comment on my coding as well.