Простая на первый взгляд задача оказалась мне не под силу.
Дано: Есть простая таблица из двух столбцов Код и Покупатель. При вставке Покупателя из списка необходимо вставить в столбец следующий свободный код, первые коды для каждого покупателя вводятся руками по логике: 20 (3 буквы) 12 / Номер кода формата 00 (Более 99 быть не может). Необходимо при введение в столбце B имени из списка сгенерировать код следующий за максимальным. Например для Коли первый код 20КОЛ12/01, при введение в следующей строке еще одного Коли код 20КОЛ12/02. При этом если так случилось что коды 20КОЛ12/01 и 20КОЛ12/03 есть, то при вставке получается 20КОЛ12/02.
Логически понимаю что наверно необходимо наполнить массив по признаку Коля. Т.е. посчитать кол-во Коль от строки 2 до текущей, создать пустой двумерный массив. Далее через Mid и Left разложить на код и номер кода и наполнить 2 столбца массива. Далее перебираем через цикл (по длине массива) коды i = Код * 1? Если значения нет - проверяем Len, если = 1, то Номер кода = "0" & i , Далее переменную NewCode = Массив(1) + Номер кода
Но что то не очень понимаю как создать пустой массив и наполнить его. Возможно есть более простое решение или альтернативные варианты решения задачи?
phelex написал: .е. посчитать кол-во Коль от строки 2 до текущей, создать пустой двумерный массив.
нет не так. нужно создать словарь из номеров 01 .02......которые есть в списке, а потом в цикле от 01 до 99 проверить. Первый которого нет. вам подходит.
phelex, yне много не то что Вам нужно, работать только если будут по порядку идти согласно количеству - можно допилить проверку, но я пас сегодня)
Код
Private Sub Worksheet_Change(ByVal RTarget As Range)
Dim Codes As Variant
Dim LRow As Long
Dim NewCode As String
If RTarget.CountLarge > 1 Then Exit Sub: If RTarget.Value = "" Then Exit Sub
If Not Intersect(RTarget, Range("B2:B1500")) Is Nothing Then
x = Application.WorksheetFunction.CountIf(Range(Cells(2, 2), Cells(RTarget.Row - 1, 2)), Cells(RTarget.Row, 2)) + 1
If Len(x) = 1 Then
Cells(RTarget.Row, 1) = "20" & Left(Cells(RTarget.Row, 2), 3) & "12/" & "0" & x
Else
Cells(RTarget.Row, 1) = "20" & Left(Cells(RTarget.Row, 2), 3) & "12/" & x
End If
End If
End Sub
БМВ, можно чуть подробнее, такой вариант тоже подходит, но не совсем понимаю как создать справочник и список для сравнения.
Mershik, не верно прочитано условие НЕ нужно собирать из 3х букв + вы предлагаете "Кол-во повторов" + 1, а они могут идти в разрыве, например 01, 03, 04 результатом должен быть 02. Но все ровно спасибо за попытку.
If RTarget.CountLarge > 1 Then Exit Sub
If RTarget.Value = "" Then Exit Sub
If Not Intersect(RTarget, Range("B2:B1500")) Is Nothing Then
Prefix = 20 & UCase(Left(RTarget.Value, 3)) & "12/"
Set odic = CreateObject("scripting.dictionary")
Arr = Range("a2:a1500")
For Each vol In Arr
If vol Like Prefix & "*" Then odic.Add CInt(Right(vol, 2)), CInt(Right(vol, 2))
Next
For i = 1 To odic.Count + 1
If Not odic.exists(i) Then Exit For
Next
RTarget.Offset(, -1).Value = Prefix & Format(i, "00")
End If
Хотя это Arr = Range("a2:a1500") мне не нравится.
Прикольный эффект при выборе несколько раз в одной ячейке одинаковых значений.
тогда уж Arr = Range(Cells(2,1),Cells(RTarget.Row-1 , 1)) но тогда надо контролировать чтоб после не было введенных значений. Так как исходя из формата /00 не более 99 значений, то это не принципиально, но для общего случая
Код
If RTarget.CountLarge > 1 Then Exit Sub
If RTarget.Value = "" Then Exit Sub
If Not Intersect(RTarget, Range("B2:B1500")) Is Nothing Then
Prefix = 20 & UCase(Left(RTarget.Value, 3)) & "12/"
Set odic = CreateObject("scripting.dictionary")
Arr = Range(Cells(2, 1), Cells(RTarget.Row - 1, 1))
For Each vol In Arr
If vol Like Prefix & "*" Then odic.Add CInt(Right(vol, 2)), CInt(Right(vol, 2))
Next
If Not odic.exists(odic.Count) Then
For i = 1 To odic.Count + 1
If Not odic.exists(i) Then Exit For
Next
Else
i = odic.Count + 1
End If
Application.EnableEvents = False
RTarget.Offset(, -1).Value = Prefix & Format(i, "00")
Application.EnableEvents = True
End If