Sub u_623()
Application.ScreenUpdating = False
ssa = Cells(Rows.Count, "a").End(xlUp).Row If ssa = 1Then ssa = 2 For Each c In Range("a2:a" & ssa)
aa = c.Value If c <> ""Then
ab = Replace(Replace(aa, ",", ";"), " ", "") & ";"
ac = Len(ab) - Len(Replace(ab, ";", ""))
s = ""
q = "" For i = 1To ac
ca = InStr(ab, ";")
cb = Left(ab, ca - 1)
cc = InStr(cb, "-")
cb_ = --Mid(ab, ca - 3, 3) If cc > 0Then
g_min = Mid(cb, cc - 3, 3)
g_max = Right(cb, 3)
g_tex = Left(cb, cc - 4)
g_klv = g_max - g_min + 1 For j = 1To g_klv
x = g_tex & Right("00" & g_min + j - 1, 3)
t = ",""" If s = ""Then t = """"
s = s & t & x & """"'ar1
u = "," If q = ""Then u = ""
q = q & u & g_min + j - 1'ar2 Next Else
t = ",""" If s = ""Then t = """"
s = s & t & cb & """"'ar1
u = "," If q = ""Then u = ""
q = q & u & cb_ 'ar2 EndIf
ab = Mid(ab, ca + 1, Len(ab)) Next
la = Len(q) - Len(Replace(q, ",", "")) + 1
k = "" For l = 1To la
lb = Evaluate("=SMALL({" & q & "}," & l & ")")
lc = Evaluate("=MATCH(" & lb & ",{" & q & "},0)")
ld = Evaluate("=INDEX({" & s & "}," & lc & ")")
y = "; " If k = ""Then y = ""
k = k & y & ld Next
c.Offset(0, 1) = k EndIf Next
Application.ScreenUpdating = True EndSub
вдруг правильно
Sub u_623()
Application.ScreenUpdating = False
ssa = Cells(Rows.Count, "a").End(xlUp).Row If ssa = 1Then ssa = 2 For Each c In Range("a2:a" & ssa)
aa = c.Value If c <> ""Then
ab = Replace(Replace(aa, ",", ";"), " ", "") & ";"
ac = Len(ab) - Len(Replace(ab, ";", ""))
s = ""
q = "" For i = 1To ac
ca = InStr(ab, ";")
cb = Left(ab, ca - 1)
cc = InStr(cb, "-")
cb_ = --Mid(ab, ca - 3, 3) If cc > 0Then
g_min = Mid(cb, cc - 3, 3)
g_max = Right(cb, 3)
g_tex = Left(cb, cc - 4)
g_klv = g_max - g_min + 1 For j = 1To g_klv
x = g_tex & Right("00" & g_min + j - 1, 3)
t = ",""" If s = ""Then t = """"
s = s & t & x & """"'ar1
u = "," If q = ""Then u = ""
q = q & u & g_min + j - 1'ar2 Next Else
t = ",""" If s = ""Then t = """"
s = s & t & cb & """"'ar1
u = "," If q = ""Then u = ""
q = q & u & cb_ 'ar2 EndIf
ab = Mid(ab, ca + 1, Len(ab)) Next
la = Len(q) - Len(Replace(q, ",", "")) + 1
k = "" For l = 1To la
lb = Evaluate("=SMALL({" & q & "}," & l & ")")
lc = Evaluate("=MATCH(" & lb & ",{" & q & "},0)")
ld = Evaluate("=INDEX({" & s & "}," & lc & ")")
y = "; " If k = ""Then y = ""
k = k & y & ld Next
c.Offset(0, 1) = k EndIf Next
Application.ScreenUpdating = True EndSub
PublicFunction Разбивка(ByRef rng As Range) Dim n, m, s AsString, x AsString, y AsInteger, y1 AsInteger OnErrorGoTo ErrHand Set re = CreateObject("VBScript.RegExp") Set dic = CreateObject("Scripting.Dictionary")
re.Global = True: re.Pattern = "\d+"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
arr1 = Split(s, ";") For Each n In arr1
arr2 = Split(n, "-")
x = re.Replace(arr2(0), "") IfNot dic.Exists(x) ThenSet dic(x) = CreateObject("System.Collections.ArrayList")
y = CInt(Replace(arr2(0), x, "")) IfUBound(arr2) > 0Then y1 = CInt(Replace(arr2(1), x, "")) Else y1 = y For m = y To y1 IfNot dic(x).contains(m) Then dic(x).Add m Next m Next n
s = "" For Each n In dic
dic(n).Sort For Each m In dic(n)
s = s & "; " & n & Format(m, "0##") 'dic(n).Item Next Next
Разбивка = Mid(s, 3) ExitFunction
ErrHand:
Разбивка = "Ошибка" EndFunction
Можно ещё пользовательской функцией (UDF)
PublicFunction Разбивка(ByRef rng As Range) Dim n, m, s AsString, x AsString, y AsInteger, y1 AsInteger OnErrorGoTo ErrHand Set re = CreateObject("VBScript.RegExp") Set dic = CreateObject("Scripting.Dictionary")
re.Global = True: re.Pattern = "\d+"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
arr1 = Split(s, ";") For Each n In arr1
arr2 = Split(n, "-")
x = re.Replace(arr2(0), "") IfNot dic.Exists(x) ThenSet dic(x) = CreateObject("System.Collections.ArrayList")
y = CInt(Replace(arr2(0), x, "")) IfUBound(arr2) > 0Then y1 = CInt(Replace(arr2(1), x, "")) Else y1 = y For m = y To y1 IfNot dic(x).contains(m) Then dic(x).Add m Next m Next n
s = "" For Each n In dic
dic(n).Sort For Each m In dic(n)
s = s & "; " & n & Format(m, "0##") 'dic(n).Item Next Next
Разбивка = Mid(s, 3) ExitFunction
ErrHand:
Разбивка = "Ошибка" EndFunction
Пример обозначения: 3KM1.3, где ● 3 - это часть изделия, состоящая например из панели или ячейки или шкафа - номер оболочки; ● KM - тип оборудования (контактор); ● 1 - порядковый номер оборудования; ● 3 - порядковый номер составляющего оборудования/аксессуар (например катушка или дополнительный контакт вх. в состав контактора); ● точка - разделитель. Т. е. 3KM1.3 - это составляющая часть контактора KM, которая в ходит в состав панели № 3.
Элемент может быть иметь форму: полную - 3KM1.3; расширенную - KM1.1; стандартную - KM1; единичную - KM.
Пример обозначения: 3KM1.3, где ● 3 - это часть изделия, состоящая например из панели или ячейки или шкафа - номер оболочки; ● KM - тип оборудования (контактор); ● 1 - порядковый номер оборудования; ● 3 - порядковый номер составляющего оборудования/аксессуар (например катушка или дополнительный контакт вх. в состав контактора); ● точка - разделитель. Т. е. 3KM1.3 - это составляющая часть контактора KM, которая в ходит в состав панели № 3.
Элемент может быть иметь форму: полную - 3KM1.3; расширенную - KM1.1; стандартную - KM1; единичную - KM.4step
Сообщение отредактировал 4step - Понедельник, 11.07.2022, 15:03
PublicFunction Разбивка(ByRef rng As Range) Dim n, m, s AsString, x AsString, y AsInteger, y1 AsInteger OnErrorGoTo ErrHand Set re = CreateObject("VBScript.RegExp") Set dic = CreateObject("System.Collections.SortedList")
re.Global = True: re.Pattern = "(\d+)$"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
arr1 = Split(s, ";") For Each n In arr1 If n <> ""Then If re.Test(n) Then
arr2 = Split(n, "-")
x = re.Replace(arr2(0), "") IfNot dic.Contains(x) ThenSet dic(x) = CreateObject("Scripting.Dictionary")
y = CInt(Replace(arr2(0), x, ""))
i = Len(Replace(arr2(0), x, "")) IfUBound(arr2) > 0Then y1 = CInt(Replace(arr2(1), x, "")) Else y1 = y For m = y To y1 IfNot dic(x).Exists(CStr(m)) Then dic(x).Add CStr(m), i Next m Else
i = Len(n) IfNot dic.Contains(n) ThenSet dic(n) = CreateObject("Scripting.Dictionary") IfNot dic(n).Exists(CStr(n)) Then dic(n).Add CStr(n), -1 EndIf EndIf Next n
s = "" For n = 0To dic.Count - 1 For Each m In dic(dic.GetKey(n)) If dic(dic.GetKey(n)).Item(m) > 0Then IfCInt(dic(dic.GetKey(n)).Item(m)) - Len(m) > 0Then
s = s & "; " & dic.GetKey(n) & String(dic(dic.GetKey(n)).Item(m) - Len(m), "0") & m Else
s = s & "; " & dic.GetKey(n) & m EndIf Else
s = s & "; " & m EndIf Next Next
Разбивка = Mid(s, 3) ExitFunction
ErrHand:
Разбивка = "Ошибка" EndFunction
Разбивает по последнему числу, либо до точки, либо до любого символа. Такие значения как 33А-А36, или QF1.1-QF3.1 выдадут ошибку
Попробуйте так:
PublicFunction Разбивка(ByRef rng As Range) Dim n, m, s AsString, x AsString, y AsInteger, y1 AsInteger OnErrorGoTo ErrHand Set re = CreateObject("VBScript.RegExp") Set dic = CreateObject("System.Collections.SortedList")
re.Global = True: re.Pattern = "(\d+)$"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
arr1 = Split(s, ";") For Each n In arr1 If n <> ""Then If re.Test(n) Then
arr2 = Split(n, "-")
x = re.Replace(arr2(0), "") IfNot dic.Contains(x) ThenSet dic(x) = CreateObject("Scripting.Dictionary")
y = CInt(Replace(arr2(0), x, ""))
i = Len(Replace(arr2(0), x, "")) IfUBound(arr2) > 0Then y1 = CInt(Replace(arr2(1), x, "")) Else y1 = y For m = y To y1 IfNot dic(x).Exists(CStr(m)) Then dic(x).Add CStr(m), i Next m Else
i = Len(n) IfNot dic.Contains(n) ThenSet dic(n) = CreateObject("Scripting.Dictionary") IfNot dic(n).Exists(CStr(n)) Then dic(n).Add CStr(n), -1 EndIf EndIf Next n
s = "" For n = 0To dic.Count - 1 For Each m In dic(dic.GetKey(n)) If dic(dic.GetKey(n)).Item(m) > 0Then IfCInt(dic(dic.GetKey(n)).Item(m)) - Len(m) > 0Then
s = s & "; " & dic.GetKey(n) & String(dic(dic.GetKey(n)).Item(m) - Len(m), "0") & m Else
s = s & "; " & dic.GetKey(n) & m EndIf Else
s = s & "; " & m EndIf Next Next
Разбивка = Mid(s, 3) ExitFunction
ErrHand:
Разбивка = "Ошибка" EndFunction
Разбивает по последнему числу, либо до точки, либо до любого символа. Такие значения как 33А-А36, или QF1.1-QF3.1 выдадут ошибкуmsi2102