Solved: add to existing value by matching

[ndendrinos]

I find it difficult to explain this so I attach a small but explicit attachment.

[Bob Phillips]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MatchRow As Long

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("A2:A10")) Is Nothing Then Target.Offset(0, 1).Select

Dim FindRange As Range
If Intersect(Target, Me.Range("B2:B10")) Is Nothing Then Exit Sub

If WorksheetFunction.CountIf(Me.Range("B2:B10"), Target.Value) > 1 Then

If MsgBox("You have chosen this product previously. Would you like to add to the quantity already ordered ?", vbYesNo + vbInformation, "Attention") = vbYes Then

MatchRow = Application.Match(Target.Value, Me.Range("B2:B10"), 0)
Me.Cells(MatchRow + 1, "C").Value = Me.Cells(MatchRow + 1, "C").Value + Target.Offset(0, 1).Value
Me.Cells(Target.Row, "A").Resize(0, 3).ClearContents
Else
ActiveCell.Offset(0, -1).Offset(0, 1).ClearContents
Selection.Offset(-0, -1).ClearContents
End If
End If

ws_exit:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("B2:B10")) Is Nothing Then

UserForm1.Show

End If
End Sub

[ndendrinos]

Hello and thanks for the code XLD
Could it be that there is a confict with this line in the code:


Application.EnableEvents = False
for using your suggestion I loose the functionality of the userform showing after a selection change.
Here is the revised file

[Bob Phillips]

Try this.

Change the form code to



Private Sub lstSelection_Click()
'if the listindex of listbox equals -1 ... nothing selected
If lstSelection.ListIndex = -1 Then
MsgBox "No item selected", vbExclamation
Exit Sub
End If

Me.Hide

End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub UserForm_Activate()
Me.lstSelection.ListIndex = -1
End Sub


and the sheet code to



Private Sub Worksheet_Change(ByVal Target As Range)
Dim MatchRow As Long
Dim FindRange As Range

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("A2:A10")) Is Nothing Then

With UserForm1

.Show
If .lstSelection.ListIndex >= 0 Then

Target.Offset(0, 1).Value = .lstSelection.Value
MatchRow = GetRow(Target.Offset(0, 1), Me.Range("B2:B10"))
Worksheets("SalesCatalog").Range("SelectionLink") = .lstSelection.ListIndex + 1
Target.Offset(0, 1).Value = Worksheets("SalesCatalog").Range("D1").Value
Target.Offset(0, 2).Value = Worksheets("SalesCatalog").Range("E1")

If MatchRow > 0 Then

If MsgBox("You have chosen this product previously. " & _
"Would you like to add to the quantity already ordered ?", _
vbYesNo + vbInformation, "Attention") = vbYes Then

Me.Cells(MatchRow + 1, "C").Value = Me.Cells(MatchRow + 1, "C").Value + Target.Offset(0, 2).Value
Me.Cells(Target.Row, "A").Resize(1, 3).ClearContents
End If
End If
End If
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

Private Function GetRow(ByVal Target As Range, ByVal Lookup As Range) As Long
On Error Resume Next
GetRow = Application.Match(Target.Value, Lookup, 0)
End Function

[ndendrinos]

Maybe my bad but doing the revisions as per your last suggestion I can now see the userform on selecton change

If I choose yes : the value does not add to the "matched" previous entry but rather clears the last entry prior to the userform showing.

The option "No" does not clear the last entry prior to the userform showing as it did before.

I attache Test3 for your perusal with thanks.

[Bob Phillips]

Yes adds to the matched value here.

[ndendrinos]

Not here I'm afraid.
Just to be on the same page ... I'm using Excel edition 2002 and document with pictures , in attachment Test4, what I hope to learn from this posting. Hope you give it a moment of your time.
Thank you xld

[Bob Phillips]

LOL! I really messed up, I added to the unit price, not the quantity.

Try this



Private Sub Worksheet_Change(ByVal Target As Range)
Dim MatchRow As Long
Dim FindRange As Range

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("A2:A10")) Is Nothing Then

With UserForm1

.Show
If .lstSelection.ListIndex >= 0 Then

Target.Offset(0, 1).Value = .lstSelection.Value
MatchRow = GetRow(Target.Offset(0, 1), Me.Range("B2:B10"))
Worksheets("SalesCatalog").Range("SelectionLink") = .lstSelection.ListIndex + 1
Target.Offset(0, 1).Value = Worksheets("SalesCatalog").Range("D1").Value
Target.Offset(0, 2).Value = Worksheets("SalesCatalog").Range("E1")

If MatchRow > 0 Then

If MsgBox("You have chosen this product previously. " & _
"Would you like to add to the quantity already ordered ?", _
vbYesNo + vbInformation, "Attention") = vbYes Then

Me.Cells(MatchRow + 1, "A").Value = Me.Cells(MatchRow + 1, "A").Value + Target.Value
Me.Cells(Target.Row, "A").Resize(1, 3).ClearContents
End If
End If
End If
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

[ndendrinos]

Thank you xld for visiting again and solving it for me.
I've added a little bit to your code to do this (probably badly done but it works)

when entering a "Qty" and pressing "enter"
the cell adjacent to it is selected and the userform shows.

When adding (choosing "yes") and after the "Qty" is added to the "matching row" the user can enter a new qty in column A and resume a new selection

Finally if the choice is "No" then the last input over the three columns is cleared.

I enclose the finished revision for anyone that might be interested .

[ndendrinos]

I should be doing this in my previous thread but I marked it "solved" in haste as it needs one more edition and since I do not know how to delete the "Solved" wording I start this new one.

Using the attachment please select A9 and enter any quantity" then select from the UserForm "tomatos"

Since this is not a duplicate of previous selections the Msgbox should not appear and the choice should stand.

The way I interpret the code the matching is done in sheet "SalesCatalog" and a match unless I'm wrong, will always be found since all products are listed.
Could the matching not be done in "sheet1 " instead and matched to previous selections?

In the affirmative can the code avoid creating extra columns and filtering? as I cannot afford this with my present setup.

Thank you

[Bob Phillips]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MatchRow As Long
Dim FindRange As Range

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("A2:A10")) Is Nothing Then

With UserForm1

.Show
If .lstSelection.ListIndex >= 0 Then

Target.Offset(0, 1).Value = .lstSelection.Value
MatchRow = GetRow(Target.Offset(0, 1), Me.Range("B2:B10"))
Worksheets("SalesCatalog").Range("SelectionLink") = .lstSelection.ListIndex + 1
Target.Offset(0, 1).Value = Worksheets("SalesCatalog").Range("D1").Value
Target.Offset(0, 2).Value = Worksheets("SalesCatalog").Range("E1")

If MatchRow > 0 And MatchRow + 1 <> Target.Row Then

If MsgBox("You have chosen this product previously. " & _
"Would you like to add to the quantity already ordered ?", _
vbYesNo + vbInformation, "Attention") = vbYes Then

Me.Cells(MatchRow + 1, "A").Value = Me.Cells(MatchRow + 1, "A").Value + Target.Value
Me.Cells(Target.Row, "A").Resize(1, 3).ClearContents
Else

Me.Cells(Target.Row, "A").Resize(1, 3).ClearContents
End If
End If
End If
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

Private Function GetRow(ByVal Target As Range, ByVal Lookup As Range) As Long
On Error Resume Next
GetRow = Application.Match(Target.Value, Lookup, 0)
End Function

[ndendrinos]

Just great xld :friends: