Редактировать (смежные) ячейки с помощью Find ()

Question

Я пишу небольшой макрос для поиска и сортировки штрих-кодов.

Идея состоит в том, что штрих-коды сканируются в ячейку C1, тогда предполагается, что макрос подсчитывает количество сканирований одного и того же кода. Если штрих-код отсутствует в списке (столбец B: B), следует добавить новый штрих-код в список (столбец B: B).

Мне удалось использовать синтаксис Find (), однако мне не удалось отредактировать с ним ни одну ячейку. Единственное, что я могу сделать, это MsgBox "" Я пытался:

Range("a5").Value = 5

Это не работает

Это код, который у меня сейчас есть:

Private Sub Worksheet_Change(ByVal Target As Range)    
    If Range("C1") = "" Then MsgBox "No input"

    Dim barcodes As Range        
    Set barcodes = Range("B:B").Find(What:=Range("C1").Value, After:=Range("B2"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, MatchByte:=True, SearchFormat:=False)

    If Not barcodes Is Nothing And Not Range("C1") = "" Then
        MsgBox "Found"
    End If

    If barcodes Is Nothing And Not Range("C1") = "" Then
        MsgBox "New product"
    End If
End Sub

Для MsgBox "Found" Вместо этого я хочу код, который подсчитывает количество сканирований одного и того же штрих-кода в соседней ячейке справа.

А для Msgbox "New product" Я хочу написать деталь, которая добавляет новый код в список, в данном случае Колонка B: B

Answer 1

С этим кодом вам понадобится лист с именем «База данных», где вы будете хранить каждое сканирование, а позже он станет источником, например, для сводной таблицы:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Barcode As String, i As Long, wsDB As Worksheet, LastRow As Long
    Dim DictBarcodes As New Scripting.Dictionary 'You need to check the Microsoft Scripting Runtime reference for this to work

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set wsDB = ThisWorkbook.Sheets("DataBase")

    With Target
        If .Range("C1") = vbNullString Then MsgBox "No input"
        On Error Resume Next

        'loop through all the barcodes and store them into a dictionary
        For i = 1 To .Rows.Count
            If .Cells(i, 2) = vbNullString Then Exit For 'skip the loop once a blank cell is found
            DictBarcodes.Add .Cells(i, 1), i 'this will raise an error if there are duplicates
        Next i

        'If the value doesn't exist we add it to the list
        If Not DictBarcodes.Exists(.Cells(1, 3)) Then
            LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
            .Cells(LastRow, 2) = .Cells(1, 3)
        End If
    End With

    'Either it exists or not, store it to the data base to keep tracking
    With wsDB
        .Cells(1, 1) = "Barcode"
        .Cells(1, 2) = "Date Scan"
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(LastRow, 1) = .Cells(1, 3)
        .Cells(LastRow, 2) = Now
    End With

    'Finally the output on the adjacent cell
    Target.Cells(1, 4) = Application.CountIf(wsDB.Range("A:A"), Target.Cells(1, 3))

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Answer 2

Ниже приведено: A) , чтобы убедиться, что у вас нет совпадений (используйте IsError, который возвращает логическое значение), чтобы определить, нужно ли вам добавить значение и начать счетчик сканирования с 1 или B) , если вам нужно найти предыдущую запись (используя Match()) и добавить к счетчику:

If IsError(Application.Match(Cells(1,3).Value,Columns(2),0)) Then 
    lr = cells(rows.count,2).end(xlup).row
    Cells(lr+1,2).Value = Cells(1,3).Value
    Cells(lr+1,1).Value = 1
Else 
    r = Application.match(Cells(1,3).Value,Columns(2),0)
    cells(r,1).value = cells(r,1).value + 1
End If

---

Edit1:

Обновлены номера столбцов для второй подпрограммы для комментария из OP, при этом исключая первую подпрограмму и переписывая ее.