All of the code below goes into the codesheet of your ENTERED DATA tab. Then save the workbook in XLSM format. You may like to use the attached workbook for learning your way with this code.
Private Enum Ned ' worksheet "Entered Data"
' 120
NedFirstDataRow = 2 ' change to suit
NedCust = 1 ' Columns: 1 = Column A
NedPart ' 2 = Column B
NedRev ' No assigned value means "previous + 1"
NedQty
NedCart
NedShelf
End Enum
Private Enum Nct ' worksheets "Cart x"
' 120
NctPart ' first enum without assigned value = 0
NctRev
NctQty
NctShelfRow = 1
NctCustRow
NctCapsRow
NctFirstDataRow
End Enum
Private Sub Worksheet_Change(ByVal Target As Range)
' 120
Dim Trigger As Range ' the range to which this proc responds
Dim Rl As Long ' last used row
Dim Arr As Variant ' the entire entry row
Rl = Cells(Rows.Count, NedCust).End(xlUp).Row
Set Trigger = Range(Cells(NedFirstDataRow, NedCust), Cells(Rl, NedShelf))
If Not Application.Intersect(Target, Trigger) Is Nothing Then
' prevent changes made by this procedure from
' triggering another call of this procedure
Application.EnableEvents = False
With Target.Cells(1) ' process only the first cell
' this test imposes restrictions:
' the 6 columns must be contiguous,
' Shelf must be last and no other entries in the row:-
' No action until all cells are filled
If WorksheetFunction.CountA(Rows(.Row)) = NedShelf Then
If (.Column = NedCust) Then
' don't change the Customer name last
MsgBox "You can't change the Customer's name for this entry.", _
vbInformation, "Entry already posted"
Application.Undo
.Select
Else
Arr = Trigger.Rows(.Row - NedFirstDataRow + 1).Value
WriteCartEntry Arr
End If
End If
End With
Application.EnableEvents = True
End If
End Sub
Private Sub WriteCartEntry(Arr As Variant)
' 120
Const Cart As String = "Cart " ' with a trailing space
Dim Ws As Worksheet ' CART sheet
Dim Clm As Long ' target column in CART
Dim Rt As Long ' target row in Cart
On Error Resume Next
Set Ws = Worksheets(Cart & CStr(Arr(1, NedCart)))
If Err Then
MsgBox "The worksheet " & Chr(34) & Cart & CStr(Arr(1, NedCart)) & _
""" doesn't exist.", vbInformation, "Missing worksheet"
Else
On Error GoTo 0
Clm = EntryColumn(Arr, Ws)
If Clm = 0 Then AppendColumnSet Arr, Ws
Rt = EntryRow(Arr(1, NedPart), Clm, Ws)
If Rt = 0 Then
Rt = Ws.Cells(Ws.Rows.Count, Clm).End(xlUp).Row + 1
If WorksheetFunction.CountA(Ws.Rows(Rt)) = 0 Then Rt = AddCartRow(Ws)
End If
With Ws.Rows(Rt)
.Cells(Clm + NctPart).Value = Arr(1, NedPart)
.Cells(Clm + NctRev).Value = Arr(1, NedRev)
.Cells(Clm + NctQty).Value = Arr(1, NedQty)
End With
End If
Err.Clear
End Sub
Private Function EntryColumn(Arr As Variant, _
Ws As Worksheet) As Long
' 120
' return 0 if not found
Dim Rng As Range ' range to search in
Dim Crit As Variant ' search criterium
Dim Fnd As Range ' cell where match was found
Dim FirstFound As Long
Set Rng = Ws.Rows(NctShelfRow)
Crit = CartShelfId(Arr(1, NedShelf))
With Rng
Set Fnd = .Find(Crit, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows, xlNext, False)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Column
Do
' both, Shelf and Customer IDs must match
If Ws.Cells(NctCustRow, Fnd.Column).Value = CartCustId(Arr(1, NedCust)) Then
EntryColumn = Fnd.Column
Exit Do
End If
Set Fnd = .FindNext(Fnd)
Loop While Not Fnd Is Nothing
End If
End With
End Function
Private Function EntryRow(ByVal Part As String, _
ByVal Clm As Long, _
Ws As Worksheet) As Long
' 120
' return 0 if not found
Dim Fnd As Range ' cell where match was found
Set Fnd = Ws.Columns(Clm).Find(Part)
If Not Fnd Is Nothing Then EntryRow = Fnd.Row
End Function
Private Function CartCustId(ByVal Id As String) As String
' 120
Dim Fun As String ' function return value
Fun = Id
If InStr(Fun, "(") Then
Fun = Mid(Fun, 2, Len(Fun) - 2)
End If
CartCustId = UCase(Fun)
End Function
Private Function CartShelfId(ByVal Id As String) As String
' 120
Dim Fun As String ' function return value
Fun = Id
If InStr(1, Fun, "shelf", vbTextCompare) = 0 Then
If Val(Fun) Then Fun = Fun & " shelf" ' with leading space
End If
If InStr(Fun, ":") = 0 Then Fun = Fun & ":"
CartShelfId = UCase(Fun)
End Function
Private Sub AppendColumnSet(Arr As Variant, _
Ws As Worksheet)
' 120
Dim Ct As Long ' target column
Dim Rng As Range
With Ws
Ct = .Cells(NctCapsRow, .Columns.Count).End(xlToLeft).Column + 1
.Range(.Columns(1), .Columns(NctQty + 1)).Copy Destination:=.Cells(1, Ct)
Set Rng = .Range(.Cells(NctFirstDataRow, Ct), _
.Cells(.Rows.Count, Ct + NctQty).End(xlUp))
Rng.ClearContents
.Cells(NctShelfRow, Ct).Value = CartShelfId(Arr(1, NedShelf))
.Cells(NctCustRow, Ct).Value = CartCustId(Arr(1, NedCust))
End With
End Sub
Private Function AddCartRow(Ws As Worksheet) As Long
' 120
' return the number of the added row
Dim R As Long ' loop counter: row
With Ws
R = .Cells(.Rows.Count, NedCust).End(xlUp).Row
Do
R = R + 1
If WorksheetFunction.CountA(.Rows(R)) = 0 Then Exit Do
Loop
.Rows(R - 1).Copy
.Rows(R).PasteSpecial xlPasteFormats
End With
Application.CutCopyMode = False
AddCartRow = R
End Function
Very broadly speaking, when you add a new item in the ED sheet the procedure runs but takes no action if not all components of a row have been entered. It refuses to take action if the customer name is changed after, presumably, an entry in a CART sheet has already been made. In fact, this proibition should be extended to the shelf posiution as well.
I thought your arrangement for shelves and customer names isn't quite what it should be but went with the present arrangement. That leads to a new set of columns being added if Shelf and Customer don't match. Note that you can change existing entries, except for the customer name.
Inconsisting spelling of customer names (with and without parenthesis) and shelf IDs required some unnecessary programming but the functions are all there now - ready to become obsolete when you streamline your project. The long and the short is that I did the programming but you will need to do the testing. The program is quite complex and there are niches neither one of us may have thought about. In order to test successfully you will have to understand the program. Toward that end I added some comments which I commend to your attention. Make sure you fully understand them.
Good luck!