'**************************************************************
'****************Assign Code Tags To Worksheet Buttons*********
Sub Add()
AddUpdateRecord xlAdd
End Sub
Sub EditUpdate()
AddUpdateRecord xlEditBox
End Sub
Sub Clear()
EventsEnable False
ClearDataEntry
EventsEnable True
End Sub
'*************************************************************
'*************************************************************
Sub AddUpdateRecord(ByVal Action As Integer)
'V2 12 - 5 - 2014
Dim InputData As Range, Item As Range
Dim Data(54) As Variant
Dim RecRow As Long
Dim i As Integer, a As Integer
Dim msg As Variant
Dim msgbx As Integer
msg = Array("Database Updated", "New Record Add To DataBase")
On Error GoTo exitsub
If Action = xlAdd Then
RecRow = GetRow(xlLastCell) + 1
If Not wsInput.Range("CheckID") Then
wsInput.Range("CurrRec").Value = RecRow - 1
a = 1
Else
MsgBox "Record Already Exists On Database", 16, "Record Exists"
GoTo exitsub
End If
Else
RecRow = GetRow(xlRows) + 1
a = 0
End If
Set InputData = wsInput.Range("OrderEntry")
For Each Item In InputData
If Item.Value = "" And UCase(Item.Offset(0, 1).Value) = "X" Then
MsgBox "Please Complete Required Field", 16, "Data Incomplete"
Item.Select
GoTo exitsub
Else
Data(i) = Item.Value
i = i + 1
End If
Next
If Action = xlAdd Then
msgbx = MsgBox(wsInput.Range("OrderID").Value & Chr(10) & _
"Do You Want To Add New Record To Database?", 36, "New Record")
If msgbx = 7 Then GoTo exitsub
End If
EventsEnable False
With wsInput
.Range("OrderID").Value = .Range("Z5").Value
.Range("Z5").Value = .Range("Z5").Value + 1
.Buttons(8).Caption = "Clear"
End With
With wsDatabase
.Unprotect
.Range(.Cells(RecRow, 3), .Cells(RecRow, 56)).Value = Data
With .Cells(RecRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(RecRow, "B").Value = Application.UserName
End With
MsgBox msg(a), 48, msg(a)
exitsub:
EventsEnable True
End Sub
Sub ClearDataEntry()
'V2 12 - 5 - 2014
Dim myCopy As Range
If wsInput Is Nothing Then Set wsInput = Worksheets("Input")
With wsInput
If .Buttons(8).Caption = "Clear" Then
If Not NewRefID Then GoTo myerror
msg = MsgBox("Do You Want To Clear Entry To Add New Record?" & Chr(10) & _
" Press Yes To Continue", 36, "Add New Record")
If msg = 7 Then Exit Sub
'cells to copy from Input sheet - some contain formulas
Set myCopy = .Range("OrderEntry")
'clear input cells that contain constants
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.Goto .Cells(1) ', Scroll:=True
End With
'no record selected, so clear order ID #
.Range("OrderSel").ClearContents
'store active record row
.Range("Z6").Value = .Range("CurrRec").Value
'clear record
.Range("CurrRec").Value = 0
On Error GoTo myerror
'change button cption
.Buttons(8).Caption = "Cancel"
'set new order ID
.Range("OrderID").Value = .Range("Z5").Value
.Range("D8").Select
Else
'return to active record
.Buttons(8).Caption = "Clear"
'restore active record
GetRecord xlAll, .Range("Z6").Value + 1
End If
End With
myerror:
End Sub
Function NewRefID() As Boolean
'V2 12 - 5 - 2014
Dim Response As Variant
With wsInput
.Unprotect
.Columns("X:Z").Hidden = True
With .Range("Z5")
If IsEmpty(.Value) Or Not IsNumeric(.Value) Then
Retry:
Response = InputBox("Please Enter Reference ID Start No.", "Enter ID")
If StrPtr(Response) = 0 Then
Exit Function
ElseIf Len(Response) = 0 Then
MsgBox "Reference ID Cannot be Blank", 16, "Entry Required"
GoTo Retry
Else
If IsNumeric(Response) Then
.NumberFormat = "00000"
.Value = CLng(Response)
Else
MsgBox "Invalid Input" & Chr(10) & _
"Numeric Input Only", 16, "Error"
GoTo Retry
End If
End If
End If
End With
End With
NewRefID = True
End Function
thanks
Can I ask you a question? Is it possible to store the "PartsData" sheet in the cloud and have multiple users able to work from the input sheet at the same time?
