How to archive data using vba and userform

January 8, 2018 at 12:18:06
Specs: Windows 7
Hello,
I am currently working on creating an excel userform for work. The userform is meant for a user to add information that is then put into a "data" sheet. There are 14 points of data being entered. I would like to have the data that is entered archived into an uneditable sheet, "archive". The userform also has the capability of allowing the user to edit information in the "data" sheet. Is there a way to have that data archived every time it is edited? I have figured out how to archive the data into the "archive" sheet when I discard an entry.

Below is the code I have.

Private Sub UserForm_Initialize()
txtDateNew.Value = Now
txtDateNew = Format(txtDateNew.Value, "MMM-DD-YY")
txtDateMod.Value = Now
txtDateMod = Format(txtDateMod.Value, "MMM-DD-YY")

End Sub

Private Sub cmdAdd_Click()
'dimention the variable
Dim DataSH As Worksheet
Dim Addme As Range
'set the variable
Set DataSH = Sheet1
'error handler
On Error GoTo errHandler:
'set variable for the destination
Set Addme = DataSH.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
If Me.cbProjectNew = "" Or Me.txtEntrantNew = "" Or Me.txtDateNew = "" Then
MsgBox "There is insufficient data, Please return and add the needed information"
Exit Sub
End If
'send the values to the database
With DataSH
'add the unique reference ID then all other values
Addme.Offset(0, -1) = DataSH.Range("C6").Value + 1
Addme.Value = Me.cbCropNew
Addme.Offset(0, 1).Value = UCase(Me.txtVarietyNew)
Addme.Offset(0, 2).Value = Me.cbSourceNew
Addme.Offset(0, 3).Value = Me.txtSourceYearNew
Addme.Offset(0, 4).Value = Me.cbLocationNew
Addme.Offset(0, 5).Value = Me.txtQuantityNew
Addme.Offset(0, 6).Value = Me.txtGermPNew
Addme.Offset(0, 7).Value = Me.txtGermYNew
Addme.Offset(0, 8).Value = Me.txtTKWNew
Addme.Offset(0, 9).Value = Me.cbProjectNew
Addme.Offset(0, 10).Value = UCase(Me.txtEntrantNew)
Addme.Offset(0, 11).Value = Me.txtDateNew
Addme.Offset(0, 12).Value = Me.txtNotes


End With

'add data to archive page


'sort the data by "Surname"
DataSH.Select
With DataSH
.Range("B9:o10000").Sort Key1:=Range("C9"), Order1:=xlAscending, Header:=xlGuess
End With
'clear the values after entry
Clear
Me.txtDateNew.Value = Format(Date, "MMM-DD-YY")
'communicate with the user
MsgBox "New Crop Variety successfully added"
'reset the form
On Error GoTo 0
Exit Sub
errHandler:
'if error occurs then show me exactly where the error occurs
MsgBox "Error " & Err.Number & _
" (" & Err.Description & ")in procedure cmdClear_Click of Form EmployeeDB"
End Sub

Sub Clear()
Dim ctl As Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "ListBox"
ctl.RowSource = ""
Case "ComboBox"
ctl.Value = ""
End Select
Next ctl
End Sub

Private Sub cmdClearAllNew_Click()
'clear all controls
Clear
Me.txtDateNew.Value = Format(Date, "MMM-DD-YY")
End Sub
Private Sub cmdClearAll_Click()
'clear all controls
Clear
Me.txtDateNew.Value = Format(Date, "MMM-DD-YY")
End Sub

Private Sub cmdFindVariety_Click()
'dim the variables
Dim Crit As Range
Dim FindMe As Range
Dim DataSH As Worksheet
'error handler
On Error GoTo errHandler:
'set object variables
Set DataSH = Sheet1
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
'///////////////////////////////////////////
'if header is selected add the criteria
If Me.cbCrop1.Value <> "all_column" Then
If Me.txtSearch = "" Then
DataSH.Range("q9") = ""
Else
DataSH.Range("q9") = "*" & Me.txtSearch.Value & "*"
End If
End If
'//////////////////////////////////////////
'if all columns is selected
If Me.cbCrop1.Value = "all_column" Then
'find the value in the column
Set FindMe = DataSH.Range("B9:o30000").Find(What:=txtSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'variable for criteria header
Set Crit = DataSH.Cells(8, FindMe.Column)
'if no criteria is added to the search
If Me.txtSearch = "" Then
DataSH.Range("q9") = ""
DataSH.Range("q8") = ""
Else
'add values from the search
DataSH.Range("q8") = Crit
If Crit = "ID" Then
DataSH.Range("q9") = Me.txtSearch.Value
Else
DataSH.Range("q9") = "*" & Me.txtSearch.Value & "*"
End If
'show in the userform the header that is added
Me.txtAllColumn = DataSH.Range("q8").Value
End If
End If
'/////////////////////////////////////////
'unprotect all sheets
Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$q$8:$q$9"), CopyToRange:=Range("Data!$r$8:$ae$8"), _
Unique:=False
'add the dynamic data to the listbox
lstSeedArchive.RowSource = DataSH.Range("outdata").Address(external:=True)
'protect all sheets
Protect_All
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets
Protect_All
'if error occurs then show me exactly where the error occurs
MsgBox "No match found for " & txtSearch.Text
'clear the listbox if no match is found
Me.lstSeedArchive.RowSource = ""
Exit Sub
End Sub

Private Sub cbCrop1_Change()
'dim the variable
Dim DataSH As Worksheet
'set the variable
Set DataSH = Sheet1
'establish the condition for "All_Columns"
If Me.cbCrop1.Value = "all_column" Then
DataSH.Range("q8") = ""
Else
'clear the textbox
Me.txtAllColumn = ""
'add the criteria header to the sheet
DataSH.Range("q8") = Me.cbCrop1.Value
'clear any existing criteria
DataSH.Range("q9") = ""
End If
End Sub

Private Sub lstSeedArchive_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'dim the variables
Dim i As Integer
On Error Resume Next
'find the selected list item
i = Me.lstSeedArchive.ListIndex
'add the values to the text boxes
Me.txtID.Value = Me.lstSeedArchive.Column(0, i)
Me.cbCrop2.Value = Me.lstSeedArchive.Column(1, i)
Me.txtVariety.Value = Me.lstSeedArchive.Column(2, i)
Me.cbSource.Value = Me.lstSeedArchive.Column(3, i)
Me.txtSourceYear.Value = Me.lstSeedArchive.Column(4, i)
Me.cbLocation.Value = Me.lstSeedArchive.Column(5, i)
Me.txtQuantity.Value = Me.lstSeedArchive.Column(6, i)
Me.txtGermP.Value = Me.lstSeedArchive.Column(7, i)
Me.txtGermY.Value = Me.lstSeedArchive.Column(8, i)
Me.txtTKW.Value = Me.lstSeedArchive.Column(9, i)
Me.cbProject.Value = Me.lstSeedArchive.Column(10, i)
Me.txtEntrant.Value = Me.lstSeedArchive.Column(11, i)
Me.txtDateMod.Value = Me.lstSeedArchive.Column(12, i)
Me.txtNotes.Value = Me.lstSeedArchive.Column(13, i)
On Error GoTo 0
End Sub

Private Sub cmdEdit_Click()
'declare the variables
Dim findvalue As Range
Dim cNum As Integer
Dim DataSH As Worksheet
'error handling
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
Set DataSH = Sheet1
'check for values
If txtID.Value = "" Or cbCrop2.Value = "" Then
MsgBox "There is not data to edit"
Exit Sub
End If
'clear the listbox
lstSeedArchive.RowSource = ""
'find the row to edit
Set findvalue = DataSH.Range("B:B"). _
Find(What:=Me.txtID.Value, LookIn:=xlValues, LookAt:=xlWhole)
'update the values
findvalue = txtID.Value
findvalue.Offset(0, 1) = cbCrop2.Value
findvalue.Offset(0, 2) = UCase(txtVariety.Value)
findvalue.Offset(0, 3) = cbSource.Value
findvalue.Offset(0, 4) = txtSourceYear.Value
findvalue.Offset(0, 5) = cbLocation.Value
findvalue.Offset(0, 6) = txtQuantity.Value
findvalue.Offset(0, 7) = txtGermP.Value
findvalue.Offset(0, 8) = txtGermY.Value
findvalue.Offset(0, 9) = txtTKW.Value
findvalue.Offset(0, 10) = cbProject.Value
findvalue.Offset(0, 11) = UCase(txtEntrant.Value)
findvalue.Offset(0, 12) = txtDateMod.Value
findvalue.Offset(0, 13) = txtNotes.Value
Me.txtDateMod.Value = Format(Date, "MMM-DD-YYYY")
'unprotect the worksheets for the advanced filter
Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$q$8:$q$9"), CopyToRange:=Range("Data!$r$8:$ae$8"), _
Unique:=False
'if no data exists then clear the rowsource
If DataSH.Range("r9").Value = "" Then
lstSeedArchive.RowSource = ""
Else
'add the filtered data to the rowsource
lstSeedArchive.RowSource = DataSH.Range("outdata").Address(external:=True)
End If
'return to sheet
Sheet2.Select
'Protect all sheets
Protect_All
'error block
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets
Protect_All
'show error information in a messagebox
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please notify the administrator"
End Sub

Private Sub cmdDiscard_Click()
'declare the variables
Dim findvalue As Range
Dim cDelete As VbMsgBoxResult
Dim cNum As Integer
Dim DataSH As Worksheet
Set DataSH = Sheet1
Dim x As Integer
Dim Addme As Range
'error statement
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
'check for values
If txtID.Value = "" Or cbCrop2.Value = "" Then
MsgBox "There is not data to delete"
Exit Sub
End If
'give the user a chance to change their mind
cDelete = MsgBox("Are you sure that you want to delete this entry", _
vbYesNo + vbDefaultButton2, "Are you sure????")
If cDelete = vbYes Then
'find the row
Set findvalue = DataSH.Range("B:B").Find(What:=Me.txtID.Value, _
LookIn:=xlValues, LookAt:=xlWhole)
'delete the entire row
Set Addme = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)

findvalue.Range("a1:o1").Copy
Addme.PasteSpecial (xlPasteValues)

findvalue.EntireRow.Delete
End If

'clear the controls
cNum = 12
For x = 1 To cNum
Me.Controls("Emp" & x).Value = ""
Next
'unprotect all sheets for the advanced filter
Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$q$8:$q$9"), CopyToRange:=Range("Data!$r$8:$ae$8"), _
Unique:=False
'if no data exists then clear the rowsource
If DataSH.Range("r9").Value = "" Then
lstSeedArchive.RowSource = ""
Else
'add the filtered data to the rowsource
lstSeedArchive.RowSource = DataSH.Range("outdata").Address(external:=True)
End If
'sort the data by "Surname"
DataSH.Select
With DataSH
.Range("B9:o10000").Sort Key1:=Range("C9"), Order1:=xlAscending, Header:=xlGuess
End With
'Protect all sheets
Protect_All
'return to sheet
Sheet2.Select
'error block
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets if error occurs
Protect_All
'show error information in a messagebox
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " & _
Err.Number & vbCrLf & Err.Description & vbCrLf & "Please notify the administrator"

End Sub

Private Sub cmdClose_Click()
'close the form
Unload Me
End Sub


See More: How to archive data using vba and userform

Reply ↓  Report •
Related Solutions


Ask Question