Allcodes have been revised following this logic.
If value1 is absent in current sheet entered data added to Current and Historical sheets. If value1 is found the value1 record row is updated on Current sheet and new row added to the "block" of value 1 on Historical sheet (the latest date being the first). Conditional format must be present on Current sheet.
1. Sheet "Entry page" code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CLsearch As Range
If Not Intersect(Target, Range("c2")) Is Nothing Then
With Application
.ScreenUpdating = 0
.EnableEvents = 0
Range("c3:c25").ClearContents
If Target = "" Then
.EnableEvents = 1
.ScreenUpdating = 1
Exit Sub
End If
Set CLsearch = Sheets("Current List").UsedRange.Resize(, 1).Find(Target, , xlValues, xlWhole, , xlNext)
If Not CLsearch Is Nothing Then
CLsearch.Resize(, 24).Copy
Range("c2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Range("c3:c25").HorizontalAlignment = xlCenter
End If
Range("c2").Select
.EnableEvents = 1
.ScreenUpdating = 1
End With
End If
End Sub
Private Sub Worksheet_Activate()
Range("C2").Activate
End Sub
2. Sheet "Current List"
Private Sub Worksheet_Activate()
Range("a1").Activate
End Sub
3. Module 1 codes:
Sub Submit_button_click()
Dim CLsearch As Range, HLsh As Worksheet, HLsearch As Range, response, shname, lastcell As Range
With Sheets("Entry Page")
If .Range("c2") = "" Then Exit Sub
Set CLsearch = Sheets("Current List").UsedRange.Find(.Range("c2"), , xlValues, xlWhole, , xlNext)
If Not CLsearch Is Nothing Then
response = MsgBox("Are you sure you would like to update the latest data for record #" & .Range("c2") & _
" with the new data in C3:C25 of the Entry Page?", vbYesNo + vbQuestion, "Update confirmation")
If response = 6 Then
Set HLsh = Sheets("Historical List")
Set HLsearch = HLsh.UsedRange.Find(.Range("c2"), , xlValues, xlWhole, , xlNext)
HLsearch.EntireRow.Insert CopyOrigin:=HLsearch
HLsearch.Offset(-1).Resize(, 24) = Application.Transpose(.Range("c2:c25"))
With HLsh.Range("a4", HLsh.Cells(Rows.Count, "a").End(xlUp)).Resize(, 24)
.Sort key1:=.Range("a4"), key2:=.Range("e4"), order2:=xlDescending, Header:=xlNo
.VerticalAlignment = xlVAlignCenter
End With
HLsearch.Offset(-1).Resize(, 24).Copy
Application.EnableEvents = 0
CLsearch.PasteSpecial xlPasteValuesAndNumberFormats
Application.EnableEvents = 1
Clear_entry_range
Else
.Range("c2").Activate
End If
Else
response = MsgBox("The number you entered is not yet associated with a record. Would you like to create a new one?", _
vbYesNo + vbQuestion, "Action confirmation")
If response = 6 Then
Application.EnableEvents = 0
For Each shname In Split("Current List,Historical List", ",")
With Sheets(shname)
Set lastcell = .Cells(Rows.Count, 1).End(xlUp)
If lastcell.Row > 4 Then
With lastcell
.Resize(, 24).Copy .Offset(1)
.Resize(, 24).Offset(1).Value = Application.Transpose(Sheets("Entry Page").Range("c2:c25"))
End With
Else
Sheets("Entry Page").Range("c2:c25").Copy
lastcell.Offset(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True
End If
End With
Next
Application.EnableEvents = 1
Application.CutCopyMode = 0
Clear_entry_range
MsgBox "New record added successfully", vbInformation, "New record"
End If
End If
End With
End Sub
Sub Clear_entry_range()
Application.EnableEvents = 0
Sheets("Entry Page").Range("c2:c25").ClearContents
Application.EnableEvents = 1
End Sub
Sub Enable_Events()
Application.EnableEvents = 1
End Sub
Sub CalibrationDueDate()
Dim dt As Date, dY As Double
dt = Range("C6").Value
dY = Val(Range("C7").Value)
Range("C8").Value = DateAdd("yyyy", dY, dt)
End Sub
4. Sheet "Historical List": delete all codes
LinkBack URL
About LinkBacks
Register To Reply
Okay, so the conditional formatting on the Data Entry Page is working well, by the looks of things.
Re: Code For Button To Store Data
Bookmarks