Здравствуйте, столкнулся с таким на мой взгляд сложным для меня заданием, нужен макрос обрезки надо обрезать от чисел по обе стороны 1) до первого - включительно и 2) все что идет вместе с слешем /***/ лишние нули вначале убрать
2-0033/7/2014 *** ka 2-02-07/7/2015 a 2-061/14 ИТ bn 2-0253/11/2010 2-170-1200/17/2014 _ g 2-0121/22/2011
Function obrezatj(s As String)
Dim t$
t = Split(Split(s, "-", 2)(1), "/")(0)
t = Replace(t, " ", "")
If IsNumeric(t) Then
obrezatj = --t
Else
obrezatj = t
End If
End Function
Sub Замена()
Dim cell As Range 'переменная для перебора ячеек
Dim r As Range 'переменная для диапазона используемых ячеек
Set r = Selection 'ActiveSheet.UsedRange 'Все используемые ячейки
For Each cell In r.Cells
If cell.Value Like "*-*/*" Then cell = obrezatj(cell.Value)
Next
End Sub
Function uuu$(t$)
With CreateObject("VBScript.RegExp")
If InStr(1, t, "-0") Then
.Pattern = "^2\-0+([^/]+)/"
uuu = Replace(.Execute(t)(0).Submatches(0), "0", "")
Else
.Pattern = "^2\-([^/]+)/"
uuu = .Execute(t)(0).Submatches(0)
End If
End With
End Function
Function uuu1$(t$)
With CreateObject("VBScript.RegExp")
If InStr(1, t, "-0") Then
.Pattern = "^2\-0+([^/]+)/"
If .test(t) Then uuu1 = Replace(.Execute(t)(0).Submatches(0), "0", "") Else uuu1 = t
Else
.Pattern = "^2\-([^/]+)/"
If .test(t) Then uuu1 = .Execute(t)(0).Submatches(0) Else uuu1 = t
End If
End With
End Function
добрый вечер,фактически мы меняем на ходу файл-пример,попробуйте еще uuu2 в столбце K(правда вторая строка не пойдет),нужен максимально расширенный файл-пример,на все случаи жизни регулярку не подобрать...
Код
Function uuu2$(t$)
With CreateObject("VBScript.RegExp")
If InStr(1, t, "-0") Then
.Pattern = "^2\-0+([^/]+)/"
If .test(t) Then uuu2 = .Execute(t)(0).Submatches(0) Else uuu2 = t
Else
.Pattern = "^2\-([^/]+)/"
If .test(t) Then uuu2 = .Execute(t)(0).Submatches(0) Else uuu2 = t
End If
End With
End Function