Search multiple ranges for two specific above values and modify an offset

[JubDown]

I'm currently creating an inventory list for several characters in a game. I'm trying to create an entry form above the inventory list that will search the list for if a character by that name is already carrying that item. If they are, it should add 1 to the Quantity Column. If not, it should add the data entered to the bottom of the list.


Example in context of the image below:
It should be testing cells A9 & B9 to find a match below them. So if the word spellbook is in B9 next to Adrys, it should find Adrys in A20 and Spellbook in B20, then change the quantity value in F20 to 2 by adding 1 to the existing 1. If it fails to find a match for both of those values (Adrys & Spellbook), it should add those value to the A & B cells at the very bottom of the list.
Inventories.jpg




I have been trying several different formulas, but I can never seem to get it (I'm quite new to this and only have a limited understanding. Don't even completely understand what my current formulas do).


My attempted formulas so far that haven't even seemed to be able to create anything, including performing things like Debug.Print on a success, so I'm kinda stumped. Each formula is listed below in order of length. In addition, while some seem like they would return correct values, I don't know how to make them select that cell and then change a value in an offset cell. Any help would be appreciated.

Sub Test4()
With Sheets("Inventories").Range(Cells(1, 12), Cells(1, 314))
Dim Results As Range
Dim x As Long
Dim y As Long
Set Results = Cells.Find(What = "A9")
x = Results.Row
y = Results.Column
End With
Debug.Print x, y
Debug.Print Results
End Sub

Sub Test5()
Dim cl As Range
With Worksheets("Inventories").Cells
Set cl = .Find(Range("A9"), After:=.Range("A11"), LookIn:=xlValues)
If Not cl Is Nothing Then
cl.Select
End If
End With
End Sub

Sub Test2()
Dim lr As Long
Dim i As Integer
lr = Worksheets("Inventories").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
If UCase(Worksheets("Inventories").Cells(1, 3).Value) = UCase(Worksheets("Inventories").Cells(i, 1).Value) Then
MsgBox "No matching value found"
'Sheet2.Cells(14, 5).Value = Sheet1.Cells(i, 1).Offset(, 5).Value
End If
Next i
End Sub

Sub Test3()
Dim nameCell As Range
Dim offsetCell As Range
With Sheets("Inventories").Range("A12:A314")
Set nameCell = Range("A12:A314").Cells.Find(What:=Adrys)
Set offsetCell = nameCell.Offset(0, 5)
' Now, your offsetCell has been created as a range, so go forth young padawan!
End With
For Each cell In offsetCell
If IsNumeric(cell.Value) Then
If cell.Value > 0 Then
cell.Value = cell.Value + 1
End If
Else
MsgBox "Cell " & cell.Address(0, 0) & " does not have a number"
Exit Sub
End If
Next
Debug.Print nameCell, offsetCell
End Sub

Sub Comparestwocolumns()
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim ws As Worksheet
Set ws = Sheets("Inventories")
Set ws2 = Sheets("Inventories")
For i = 9 To 9
If IsEmpty(ws.Range("A" & i)) Then
Exit For
End If
For j = 12 To 50000
If IsEmpty(ws2.Range("A" & j)) Then
Exit For
End If
If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then
If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then
Exit For
End If
End If
Next j
Next i
MsgBox ("Finished ")
End Sub


Sub Other()
Application.ScreenUpdating = False
'Declare variables
Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long, bln As Boolean, dar As Range
'Set up the count as the number of filled rows in the first column of Sheet1.
iRowL = Cells(Rows.Count, 126).End(xlUp).Row
'Cycle through all the cells in that column:
For iRow = 1 To iRowL
'For every cell that is not empty, search through the first column in each worksheet in the
'workbook for a value that matches that cell value.
If Not IsEmpty(Cells(iRow, q)) Then
For iSheet = ActiveSheet.Index + 1 To Worksheets.Count
bln = False
var = Application.Match(Cells(iRow, 2).Value, Worksheets(iSheet).Columns(8), 0)
'If you find a matching value, indicate success by setting bln to true and exit the loop;
'otherwise, continue searching until you reach the end of the workbook.
If Not IsError(var) Then
bln = True
Exit For
End If
Next iSheet
End If
'If you do not find a matching value, do not bold the value in the original list;
'if you do find a value, bold it.
If bln = False Then
Cells(iRow, 2).Font.Bold = False
Else
Cells(iRow, 2).Font.Bold = True
Range("K2:K10000").NumberFormat = "000000000000"
Range(Cells(iRow, 1), Cells(iRow, 34)).Offset(3500, 0) = Range(Cells(iRow, 1), Cells(iRow, 34)).Value
End If
Next iRow
Application.ScreenUpdating = True
End Sub

[Kenneth Hobs]

Welcome to the forum!

I am not sure what you are trying to do. In Sub Test4, you are searching by all the cells in the sheet for the value "A9" not the value in cell A9. It looks like you might be wanting to search for the value of A9 in column A?

While I can show you how that is done, is the intent to find just the first match or all matches in column A? IF the latter, a FindAll() or a Filter criterion find might be best.

As for the B9 search, I see no value in B9 in your screen snip. I assume that you want a similar search of maybe column B for value of B9? There again, is it a search for just the first match or all?

Or could the Find be to find the row or rows where both A9 and B9 values occur on the same row in the filter datarange?

[JubDown]

It is the latter of what you said. It's trying to find the row where A9 and B9 both are there, then modify a completely different cell (Cell F of the row that was found) by adding a value of 1 to the current number. If it is unable to find a row where A9 and B9 are both occuring, it should place the values of A9 and B9 on the next available empty row on the sheet. Does that make more sense?

[Kenneth Hobs]

Most are probably using a helper column to make finding such a bit easier.

Sub Find2()  
  Dim r As Range, i As Long, rn As Long, s$, s2$
  
  Set r = Range("A12", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
  
  rn = 0
  s = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose( _
    [A9:B9])), vbTab)
  For i = 1 To r.Rows.Count
    s2 = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose( _
      Range(r(i, 1), r(i, 2)))), vbTab)
    If s = s2 Then
      rn = r(i, 1).Row
      Exit For
    End If
  Next i
  
  If rn = 0 Then
    [A9:B9].Copy r(r.Rows.Count + 1, 1)
    Application.CutCopyMode = False
    Else
    Cells(rn, "F").Value = Cells(rn, "F").Value + 1
  End If
End Sub

[JubDown]

That is perfect. Thank you so much!!!! If it isn't too much to ask, is there a way to, before it copies it to the bottom row, first make it search a separate worksheet's A column for the value in cell B9 and, if it fails to find it, simply return a MsgBox saying "Item does not exist" and then it doesn't copy it to the bottom row?

There is also a small error. I have a second formula that automatically sorts a table and the table consists of the cells below it. However, copying the A9 and B9 into the bottom cell does not allow it to be sorted into the table.

[Kenneth Hobs]

The first is a simple range find.

If you are using a Table, inserting another row after its last row is a bit more work. I would need to know the name of the table.

[JubDown]

It's just named "Inventories" and fills (currently) Columns A:N and rows 12:106 w/ Row 11 being the headers.

[Kenneth Hobs]

My example file added to end of Table.

This code is same as attachment.

Sub Find2()  
  Dim r As Range, i As Long, rn As Long, s$, s2$
  Dim c As Range, lc2 As Range, ws2 As Worksheet, f As Range
  
  'Sheet 2 find range data
  Set ws2 = Worksheets("Sheet2")
  Set c = Intersect(ws2.Range("A:A"), ws2.UsedRange)
  Set lc2 = c(c.Rows.Count, c.Columns.Count)
  
  'Sheet 1 find range data
  Set r = Range("A12", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
  
  rn = 0
  s = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose( _
    [A9:B9])), vbTab)
  For i = 1 To r.Rows.Count
    s2 = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose( _
      Range(r(i, 1), r(i, 2)))), vbTab)
    If s = s2 Then
      rn = r(i, 1).Row
      Exit For
    End If
  Next i
  
  If rn = 0 Then
    Set f = c.Find([B9], lc2, xlValues, xlWhole, xlNext)
    If f Is Nothing Then
      MsgBox "Item does not exist"
      Else
      [A9:B9].Copy r(r.Rows.Count + 1, 1)
      Application.CutCopyMode = False
    End If
    Else
    Cells(rn, "F").Value = Cells(rn, "F").Value + 1
  End If
End Sub

[JubDown]

I plugged that in, but it's not putting it into the table. In the image below, the table ends at cell 108. If I modify it to end at cell 106, then the value for the plugged in cells (A9 and B9) are just placed at 107 instead. I'm wanting to force the table to expand to include the newly added values from A9 to B9, or force the copy to place it in the cells without values inside the table, if that is at all possible, so that the cells can be sorted in the table.

Ex.jpg

Codes are now as follows:

Sub InventoryAdd()  
  Dim r As Range, i As Long, rn As Long, s$, s2$
  Dim c As Range, lc2 As Range, ws2 As Worksheet, f As Range
  
  'Sheet 2 find range data
  Set ws2 = Worksheets("C - Items")
  Set c = Intersect(ws2.Range("A:A"), ws2.UsedRange)
  Set lc2 = c(c.Rows.Count, c.Columns.Count)
  
  'Sheet 1 find range data
  Set r = Range("A12", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
  
  rn = 0
  s = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose( _
    [A9:B9])), vbTab)
  For i = 1 To r.Rows.Count
    s2 = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose( _
      Range(r(i, 1), r(i, 2)))), vbTab)
    If s = s2 Then
      rn = r(i, 1).Row
      Exit For
    End If
  Next i
  
  If rn = 0 Then
    Set f = c.Find([B9], lc2, xlValues, xlWhole, xlNext)
    If f Is Nothing Then
      MsgBox "Item does not exist"
      Else
      [A9:B9].Copy r(r.Rows.Count + 1, 1)
      Application.CutCopyMode = False
    End If
    Else
    Cells(rn, "F").Value = Cells(rn, "F").Value + 1
  End If
  Worksheets("Inventories").Range("A9:B9").ClearContents
  Call Auto_Inventory_Sort
End Sub

Private Sub Auto_Inventory_Sort()'
' Auto_Inventory_Sort Macro
'


'
    Range("Inventories[[#Headers],[Carried By]]").Select
    ActiveWorkbook.Worksheets("Inventories").ListObjects("Inventories").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Inventories").ListObjects("Inventories").Sort.SortFields. _
        Add(Range("Inventories[Carried By]"), xlSortOnCellColor, xlAscending, , xlSortNormal _
        ).SortOnValue.Color = RGB(255, 255, 0)
    ActiveWorkbook.Worksheets("Inventories").ListObjects("Inventories").Sort.SortFields. _
        Add2 Key:=Range("Inventories[Carried By]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Inventories").ListObjects("Inventories").Sort.SortFields. _
        Add2 Key:=Range("Inventories[Item Type]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Inventories").ListObjects("Inventories").Sort.SortFields. _
        Add2 Key:=Range("Inventories[Damage]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Inventories").ListObjects("Inventories").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub