Как получить следующий порядковый номер с разными префиксами? - PullRequest
Новая
       0

Как получить следующий порядковый номер с разными префиксами?

0 голосов
/ 08 января 2019

Я делаю автоматический продукт SKU создатель таблицы Excel. У меня проблема: программа делает SKU в зависимости от опций, выбранных из выпадающего списка, и добавляет один номер на каждый выбранный элемент списка. Мне удалось заставить это работать, но последние 4 цифры в SKU - это уникальный номер для каждого элемента. Создание уникальных номеров - вот где у меня проблемы. У меня есть номера SKU, перечисленные в таблице

Picture

Программа добавляет новый SKU внизу таблицы. После выбора из списков есть пять чисел, например 01123. Программа должна проверить, что является следующим «свободным» порядковым номером в числах, которые начинаются с тех же 5 цифр. Как будто уже 011230001 и следующий SKU будет автоматически ассоциирован с 011230002, а если уже есть 011330001, он будет автоматически ассоциирован с 011330002. Таким образом, каждый элемент имеет уникальный SKU. Как мне это сделать?

Код для получения первых двух чисел: 

Sub kopioi1()
If Range("A2") = "Tietokoneet" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "01"
 ElseIf Range("A2") = "Komponentit" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "02"
 ElseIf Range("A2") = "Oheislaite" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "03"
 ElseIf Range("A2") = "Ohjelmisto" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "04"
 ElseIf Range("A2") = "Verkko" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "05"
 ElseIf Range("A2") = "Mobiililaite" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "06"
 ElseIf Range("A2") = "Tarvikkeet" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "07"
 ElseIf Range("A2") = "Palvelu" Then
    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Cells(eRow, 1).Value = "08"
End If
End Sub

Третий номер: 

Sub kopioi2()
If Range("B2") = "Kannettavat" Then
Cells.Find(What:="01", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "1"

 ElseIf Range("B2") = "Pöytäkoneet" Then
Cells.Find(What:="01", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "2"

 ElseIf Range("B2") = "Käytetyt" Then
Cells.Find(What:="01", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "3"

End If
End Sub

Четвертый номер: 

Sub kopioi3()
If Range("C2") = "_13" Then
Cells.Find(What:="011", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "1"

 ElseIf Range("C2") = "_14" Then
Cells.Find(What:="011", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "2"

 ElseIf Range("C2") = "_15.6" Then
Cells.Find(What:="011", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "3"

 ElseIf Range("C2") = "_17" Then
Cells.Find(What:="011", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "4"

 ElseIf Range("C2") = "Yrityskannettavat" Then
Cells.Find(What:="011", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "5"

End If
End Sub

Пятое число и последние четыре цифры: 

Sub kopioi4()
Dim cell As Range
Dim bottomA As Integer
Dim data_text As String

bottomA = Range("a" & Rows.Count).End(xlUp).Row
Dim rng As Range
Set rng = Range("A1:A" & bottomA)
If Range("D2") = "Acer" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "1"
        End If
    Next cell

 ElseIf Range("D2") = "Apple" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "2"
        End If
    Next cell

 ElseIf Range("D2") = "ASUS" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "3"
        End If
    Next cell

 ElseIf Range("D2") = "Fujitsu" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "4"
        End If
    Next cell

 ElseIf Range("D2") = "HP" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "5"
        End If
    Next cell

 ElseIf Range("D2") = "Lenovo" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "6"
        End If
    Next cell

 ElseIf Range("D2") = "Samsung" Then
    For Each cell In rng
        If Len(cell) = 4 Then
            cell.Value = cell.Value & "7"
        End If
    Next cell
End If

Range("A" & Cells.Rows.Count).End(xlUp).Select
data_text = ActiveCell.Value

        Cells.Find(What:=data_text, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True).Activate
ActiveCell.Value = ActiveCell.Value & "3"

End Sub

Ответы [ 2 ]

0 голосов
/ 09 января 2019

Попробуйте, 

Sub test()
    Dim rngDB As Range
    Dim rngT As Range
    Dim s, s2, s3, s4
    Dim n As Long

    Select Case Range("a2")
        Case "Tietokoneet"
            s = "01"
        Case "Komponentit"
            s = "02"
        Case "Oheislaite"
            s = "03"
        Case "Ohjelmisto"
            s = "04"
        Case "Verkko"
            s = "05"
        Case "Mobiililaite"
            s = "06"
        Case "Tarvikkeet"
            s = "07"
        Case "Palvelu"
            s = "08"
    End Select

    Select Case Range("b2")
        Case "Kannettavat"
            s2 = "1"
        Case "Poytakoneet"
            s2 = "2"
        Case "Kaytetyt"
            s2 = "3"
    End Select

    Select Case Range("c2")
        Case "_13"
            s3 = "1"
        Case "_14"
            s3 = "2"
        Case "_15.6"
            s3 = "3"
        Case "_17"
            s3 = "4"
        Case "Yrityskannettavat"
            s3 = "5"
    End Select
    Select Case Range("d2")
        Case "Acer"
            s4 = "1"
        Case "Apple"
            s4 = "2"
        Case "ASUS"
            s4 = "3"
        Case "Fujitsu"
            s4 = "4"
        Case "HP"
            s4 = "5"
        Case "Lenovo"
            s4 = "6"
        Case "Samsung"
            s4 = "7"
    End Select

    s = s & s2 & s3 & s4
    Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))
    n = WorksheetFunction.CountIf(rngDB, s & "*") + 1
    s = s & Format(n, "0000")
    Set rngT = Range("a" & Rows.Count).End(xlUp)
    Set rngT = rngT.Offset(1, 0)
    rngT = s

End Sub

Изображение результата

enter image description here

0 голосов
/ 08 января 2019

Надеюсь, я понял это, поскольку ваш вопрос немного расплывчатый (наверное, мне следовало сначала спросить ....)

В любом случае, ваш код, написанный в текущей форме, быстро станет очень неуправляемым. Лично я бы держал свои пары ключей и кодов в отдельных таблицах и ссылался на них в своем VBA для генерации Dictionary, но в этом примере я произвел их встроенными. Я также переписал ваши процедуры как Function, чтобы я мог ссылаться на них в мастере Sub. Вам, вероятно, придется обновить свои листовые ссылки / диапазоны, но я постарался вывести их как можно лучше.

Вкл. Sheet1 Мои входы выбраны в Row 2. Как только входы выбраны, позвоните по номеру Sub GenerateSKU. Сначала будет сгенерирован префикс в зависимости от входных данных. Затем он найдет все SKU с одинаковым префиксом и увеличит последние 4 цифры на 1. Затем он добавит новый SKU в конец списка SKU в Sheet2 и отобразит MsgBox с новым SKU.

Аналогично, их можно декодировать, выбрав SKU и запустив DecodeSKU sub 

Option Explicit
Public Sub GenerateSKU()
    Dim ExistingSKU As Range
    Dim MaxExistingSKUNum As Long, LastSKU As Long
    Dim firstExistingSKUAddress As String, NewSKU As String, SKU As String, SKUPreFix As String

    With Sheet1
        SKUPreFix = EncodeKopioi(1, .Range("A2").Value2) & _
                    EncodeKopioi(2, .Range("B2").Value2) & _
                    EncodeKopioi(3, .Range("C2").Value2) & _
                    EncodeKopioi(4, .Range("D2").Value2)
    End With

    With Sheet2
        With .Range("A:A")
            Set ExistingSKU = .Find(what:=SKUPreFix, lookat:=xlPart)
            If Not ExistingSKU Is Nothing Then
                firstExistingSKUAddress = ExistingSKU.Address
                Do
                    If Left(ExistingSKU.Value2, 5) = SKUPreFix And MaxExistingSKUNum < Val(Right(ExistingSKU.Value2, 4)) Then
                        MaxExistingSKUNum = Val(Right(ExistingSKU.Value2, 4))
                    End If
                    Set ExistingSKU = .FindNext(ExistingSKU)
                Loop Until ExistingSKU Is Nothing Or ExistingSKU.Address = firstExistingSKUAddress
            End If
        End With
        NewSKU = SKUPreFix & Format(MaxExistingSKUNum + 1, "0000")
        LastSKU = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(LastSKU + 1, 1).Value2 = NewSKU
    End With

    MsgBox NewSKU
End Sub

Public Sub DecodeSKU()
    With ActiveCell
        MsgBox EncodeKopioi(1, .Value2, True) & vbNewLine & _
               EncodeKopioi(2, .Value2, True) & vbNewLine & _
               EncodeKopioi(3, .Value2, True) & vbNewLine & _
               EncodeKopioi(4, .Value2, True)
    End With
End Sub

Public Function EncodeKopioi(KopioiNum As Long, str As String, Optional Decode As Boolean = False) As String
    Dim KopioiDict As Object: Set KopioiDict = CreateObject("Scripting.Dictionary")
    Dim MidStart As Long, MidLen As Long
    Dim key
    Select Case KopioiNum
        Case 1
            MidStart = 1
            MidLen = 2
            KopioiDict.Add key:="Tietokoneet", Item:="01"
            KopioiDict.Add key:="Komponentit", Item:="02"
            KopioiDict.Add key:="Oheislaite", Item:="03"
            KopioiDict.Add key:="Ohjelmisto", Item:="04"
            KopioiDict.Add key:="Verkko", Item:="05"
            KopioiDict.Add key:="Mobiililaite", Item:="06"
            KopioiDict.Add key:="Tarvikkeet", Item:="07"
            KopioiDict.Add key:="Palvelu", Item:="08"
        Case 2
            MidStart = 3
            MidLen = 1
            KopioiDict.Add key:="Kannettavat", Item:="1"
            KopioiDict.Add key:="Pöytäkoneet", Item:="2"
            KopioiDict.Add key:="Käytetyt", Item:="3"
        Case 3
            MidStart = 4
            MidLen = 1
            KopioiDict.Add key:="_13", Item:="1"
            KopioiDict.Add key:="_14", Item:="2"
            KopioiDict.Add key:="_15.6", Item:="3"
            KopioiDict.Add key:="_17", Item:="4"
            KopioiDict.Add key:="Yrityskannettavat", Item:="5"
        Case 4
            MidStart = 5
            MidLen = 1
            KopioiDict.Add key:="Acer", Item:="1"
            KopioiDict.Add key:="Apple", Item:="2"
            KopioiDict.Add key:="Asus", Item:="3"
            KopioiDict.Add key:="Fujitsu", Item:="4"
            KopioiDict.Add key:="HP", Item:="5"
            KopioiDict.Add key:="Lenovo", Item:="6"
            KopioiDict.Add key:="Samsung", Item:="7"
        Case Else
            Err.Raise Number:="9998", _
                      Source:="EncodeKopioi", _
                      Description:="Invalid KopioiNum"
    End Select

    If Decode = True Then
        For Each key In KopioiDict
            If KopioiDict(key) = Mid(str, MidStart, MidLen) Then
                EncodeKopioi = key
                Exit For
            End If
        Next key
    Else
        EncodeKopioi = KopioiDict(str)
    End If

    If EncodeKopioi = vbNullString Then
        Err.Raise Number:=9999, _
                  Source:="EncodeKopioi", _
                  Description:="Failed to " & IIf(Decode = False, "En", "De") & "code for " & IIf(Decode = False, "input ", "SKU ") & str
    End If
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...