match & add

[ndendrinos]

This code works well
In a row [A17:A35] I type a quantity sheet change event selects the next column to the right, a userform appears and I choose a “product”

.....A……B
1..10.…apple
2…5….pears
3…4….apple

because “apple” was chosen previously a msgbox(yes/no) appears saying that a same item was already chosen and offers to increase the previous quantity .

Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
 'this is to select adjacent cell after typing a quantity
 If Not Intersect(Target, Range("A17:A35")) Is Nothing Then Target.Offset(0, 1).Select
 
'this in case user selects a duplicate item & gives the user the choice of adding same to the previous row or delete it
Dim rngFindRange As Range
Application.EnableEvents = False
If Intersect(Target, Range("A:B")) Is Nothing Or Me.UsedRange.Rows.Count = 1 Then GoTo TidyUp
If Target.Count > 1 Then
    MsgBox "Please update only one cell at a time in columns A & B.", vbInformation
    Application.Undo
    GoTo TidyUp
 
End If
If Range("A" & Target.Row) <> "" And Range("B" & Target.Row) <> "" Then
    Set rngFindRange = Range("B1:B" & Target.Row - 1).Find(What:=Range("B" & Target.Row), LookIn:=xlValues)
        If Not rngFindRange Is Nothing Then
 
            If MsgBox("Product exists on a previous row ... Add to it?", vbYesNo) = vbNo Then
                Range("A" & Target.Row & ":E" & Target.Row).ClearContents
                GoTo TidyUp
            End If
 
            rngFindRange.Offset(0, -1) = rngFindRange.Offset(0, -1) + Range("A" & Target.Row)
 
            Range("A" & Target.Row & ":E" & Target.Row).ClearContents
             End If
            End If
            
            
            Dim LastRow As Long
    Range("A35").Select
    LastRow = ActiveCell.End(xlUp).Offset(1, 0).Select
    Range("A" & Target.Row & ":E" & Target.Row).ClearContents
 Application.EnableEvents = True
 
TidyUp:

End Sub

The problems is that I don't know how to edit the code ever since I have added two new columns .
The setup of my sheet is now like this:

....A…B…C……B
1..10……..…apple
2…5…………..pears
3…4…………..apple

Columns B&D must not be cleared (they contain formulas that are needed.
Any solution is welcome especially if it is radically different than what's shown here.

Many thanks

 

[pbornemeier]

If you change the values in blue below, the code will examine column D for the item name.

You will also have to make changes to the userform code that pops up to allow you to choose an item name. It currently writes to column B and you need to modify it to write to column A.

The modifications have not been tested, since all code was not available.

Private Sub Worksheet_Change(ByVal Target As Range)
     'this is to select adjacent cell after typing a quantity
    If Not Intersect(Target, Range("A17:A35")) Is Nothing Then Target.Offset(0, 1).Select
 
    'this in case user selects a duplicate item & gives the user the choice of adding same to the previous row or delete it
    Dim rngFindRange As Range
    Application.EnableEvents = False
    If Intersect(Target, Union(Range("A:A"), Range("D:D"))) Is Nothing Or Me.UsedRange.Rows.Count = 1 Then GoTo TidyUp

 
    If Target.Count > 1 Then
        MsgBox "Please update only one cell at a time in columns A & B.", vbInformation
        Application.Undo
        GoTo TidyUp
    End If
 
    If Range("A" & Target.Row) <> "" And Range("B" & Target.Row) <> "" Then
        Set rngFindRange = Range("D1:D" & Target.Row - 1).Find(What:=Range("D" & Target.Row), LookIn:=xlValues)
 
        If Not rngFindRange Is Nothing Then
 
            If MsgBox("Product exists on a previous row ... Add to it?", vbYesNo) = vbNo Then
                Range("A" & Target.Row & ":E" & Target.Row).ClearContents
                GoTo TidyUp
            End If
 
            rngFindRange.Offset(0, -1) = rngFindRange.Offset(0, -1) + Range("A" & Target.Row)
            Range("A" & Target.Row & ":E" & Target.Row).ClearContents
        End If
    End If
 
 
    Dim LastRow As Long
    Range("A35").Select
    LastRow = ActiveCell.End(xlUp).Offset(1, 0).Select
    Range("A" & Target.Row & ":E" & Target.Row).ClearContents
    Application.EnableEvents = True
 
TidyUp:
End Sub

 

[ndendrinos]

Hello Phil and thank you for your interest in my post.
I have uploaded a test file for your perusal here:
http://www.box.net/shared/ob0kppiue3

If someone else wants to contribute please do.

The sample shows three sheets
Sheet "Invoice" is the new format and accepts duplicates
Sheet "Invoice1" is the old format and it rejects duplicates as it should
Sheet "Invoice2" is the new format that I'm trying to emulate "Invoice1" and reject duplicates.

I have edited the code in sheet "Invoice2" with your suggestion and it does not work I'm afraid. I have adjusted the Userform11

Maybe you can spare some time and have a look.

 

[ndendrinos]

Forgot to mention that I am now using a new code in the old format in sheet "Invoice1" and would prefer to adapt sheet "Invoice2" with it.
This new code works more reliably than the one I posted here at the beginning and is included in the sample file.

Many thanks

 

[ndendrinos]

I think I finally got it like this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("D17:D35")) Is Nothing Then
    If Target.Value = "" Then UserForm11.Show
    Range("A35").End(xlUp)(2, 1).Activate
    
    'looks for duplicate and alerts
    Application.EnableEvents = False
    Dim rngFindRange  As Range
    If Range("A" & Target.Row) <> "" And Range("D" & Target.Row) <> "" Then
    Set rngFindRange = Range("D1:D" & Target.Row - 1).Find(What:=Range("D" & Target.Row), LookIn:=xlValues)
        
        If Not rngFindRange Is Nothing Then
        
          If MsgBox("Product exists on a previous row ... Do you wish to edit the quantity for it ?", vbYesNo) = vbNo Then
          Range("A" & Target.Row & ":F" & Target.Row).ClearContents
          ActiveCell.Offset(-1, 0).Select
     
                Else
                'this takes you to the qty of the duplicate
                ActiveCell.Offset(-1, 0).Select
                Selection.Copy
                '
                 rngFindRange.Offset(0, -3).Select
                 
                 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
        False, Transpose:=False
        
        Range("A17").End(xlDown).Select
                  
  Union(ActiveCell, ActiveCell.Offset(0, 3).Resize(, 3)).ClearContents
                                 
                 End If
                End If
          End If
   End If
  
   Application.EnableEvents = True
End Sub

Hope I'm not back tomorrow with another problem on this one.