Страницы: 1
RSS
Поиск следующего свободного значения
 
Друзья, приветствую!

Простая на первый взгляд задача оказалась мне не под силу.

  Дано: Есть простая таблица из двух столбцов Код и Покупатель. При вставке Покупателя из списка необходимо вставить в столбец следующий свободный код, первые коды для каждого покупателя вводятся руками по логике: 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 - 23.11.2020 21:38:58 (По просьбе модератора.)
невозможное делаем сразу, чудо - требует небольшой подготовки.
 
Цитата
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. Но все ровно спасибо за попытку.
Изменено: phelex - 24.11.2020 11:21:36
невозможное делаем сразу, чудо - требует небольшой подготовки.
 
Код
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") мне не нравится.

Прикольный эффект при выборе несколько раз в одной ячейке одинаковых значений.
Изменено: БМВ - 24.11.2020 20:17:43
По вопросам из тем форума, личку не читаю.
 
БМВ, супер, спасибо!

Замена:
Arr = Range(Cells(2,1),Cells(RTarget.Row , 1))

Для себя понял что нужно разобраться с тем что такое:
Set odic = CreateObject("scripting.dictionary")
невозможное делаем сразу, чудо - требует небольшой подготовки.
 
тогда уж 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
По вопросам из тем форума, личку не читаю.
 
БМВ, согласен, логика заполнения сверху вниз

-1 тоже дописал на тесте.
невозможное делаем сразу, чудо - требует небольшой подготовки.
Страницы: 1
Наверх