Add a Unique Value to a Specific Range - VBA

[Ty_French]

Hi all,

Hoping the community can come to my rescue once again! I am attempting to create a code which does the following:

A cell will contain a value ("J12" in my example). I want to have a macro which copies this value to the next empty cell within a range ("B6:B25") if the value is not already present within the range, and once added, offset by -1 (now in the A column) and increase the value by 1. If the value is present already, I only want to offset and increase by 1.

I have acheived something very similar in this same sheet, but unfortunately it does not allow for the range to start at the 6th row as is the case here. I also do not know how to do the result for when the value is already present, or what that code would look like...

I have included the code I am failing to adjust to reflect what I need, and I really hope someone can advise!

Application.ScreenUpdating = False

Cells(12, 10).Copy
With Sheets("Sheet1").Range("B6:B25").End(xlUp).Offset(1)
.PasteSpecial (xlPasteValues)
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = ActiveCell.Value + 1
End With

SendKeys ("^{HOME}")

Application.ScreenUpdating = True

Thank you in advance for any support,

Ty

 

[rpaulson]

you logic is difficult for me to follow.

let say cell J12 has a value of 69
if there if a cell in range ("B6:B25") that has a value of 69 then
-write the value of 70(69+1) into column "A" of the row that matches the 69?

if there is no 69 in range ("B6:B25") then add a 69 into the first blank cell in range ("B6:B25"), offset by 1 column - like C24 for example?

 

[Ty_French]

Thanks for the quick response, and apologies for not being clearer.

My example is not checking a number value, but a text value. So:

Cell J12 has the value "Computer". If "Computer" is not a present value in range "B6:B25", then it will be entered into the next blank cell in the range, and the cell in column A will be "1".
If "Computer" is present in the range, then it will not add an entry, but will add to column A in increments of 1.

I hope this is clearer. let me know if I can clarify further.

 

[rpaulson]

try this on a copy of your file.

Sub do_it()

item = [J12]
Set foundRng = Range("B5:B25").Find(item, , xlValues, xlWhole)
If foundRng Is Nothing Then r = Cells(Rows.Count, "B").End(xlUp).Row + 1 Else r = foundRng.Row

Cells(r, "B") = item
Cells(r, "A") = Cells(r, "A") + 1

End Sub

-Ross

 

[Ty_French]

Hi Ross,

Thank you - that is so close to solving the issue. What seems to be happening here is it will enter the Value shown in "J12" into "B2", then when run again it goes into each row down to "B5". At this point it works perfectly, where unique values are listed and repeated values are recognised, where the value in column A is increased by 1.

What you managed to get working there is very impressive, and I will try to work around that to solve the issue where it starts at "B2". If you know how to resolve this, please let me know!

Thank you again for your efforts and such a quick response.

Ty

 

[Alex Blakenburg]

If I understand it correctly, you don't have a heading row in row 4 so that the find next row is initially going to row 1.
If that is the case it just means adding an additional check to @rpaulson's suggested solution.
(unfortunately I run with Option Explicit turned on so I had to add some additional lines)

Sub AddOrCountItem()

    Dim Item As String, r As Long
    Dim foundRng As Range, rng As Range
   
    Set rng = Range("B5:B25")
   
    Item = Range("J12").Value
    Set foundRng = rng.Find(Item, , xlValues, xlWhole)
    If foundRng Is Nothing Then
        r = Cells(Rows.Count, "B").End(xlUp).Row + 1
        If r < rng.Cells(1).Row Then r = rng.Cells(1).Row
    Else
        r = foundRng.Row
    End If
   
    Cells(r, "B") = Item
    Cells(r, "A") = Cells(r, "A") + 1

End Sub

 

[Ty_French]

Absolutely amazing. Thank you both for the great help, so quickly.

I am still learning this side of excel, and there is so much. I greatly appreciate you solving my problem, and I will try to break down the code written to understand how to use it in similar ways in the future.

Much appreciated!

 

[Alex Blakenburg]

You're welcome. Glad we could help.

 

[rpaulson]

glad its working for you.