Имеется столбец текстовых данных, половина которых заполнена вручную разными людьми. Внутри текста есть 16-значный номер карты.
Учитывая человеческий фактор, он написан по-разному, в основном так: 6500 1234 5678 9999 6500-0101-0202-0303 6500660167026803 №6500123456789999
Реже встречаются такие, когда пишут каждые 4 цифры через пробел или тире, но где-то не ставят: 6500 11112222 3333 65009797 3545 5161 6500-0101-02020303
Сейчас я вытаскиваю номер карты таким макросом:
Код
Sub karta()
Dim x As Range, y As Range
Set y = Intersect(Selection, ActiveSheet.UsedRange)
d = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column - y.Column + 1
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Pattern = "\D6500(\D?\d{4}){3}"
For Each x In y
s = x.Value
Set objMatches = objRegExp.Execute(s)
For i = 0 To objMatches.Count - 1
Set objMatch = objMatches.Item(i)
x.Offset(, d).Value = objMatch.Value & "_"
Next
Next
'y.Offset(, d).Replace "у", ""
'y.Offset(, d).Replace " ", ""
'y.Offset(, d).Replace "-", ""
'y.Offset(, d).Replace "№", ""
End Sub
Можно ли Pattern изменить так, чтобы из кода убрать ручные обработки y.Offset(, d).Replace… То есть я вроде подобрал нужный Pattern, но теперь из вытащенной этим Pattern’ом подстроки нужно вытащить только цифры. ???
Незнаю как регулярками, но Вашу проблему можно решить так
Код
For Each x In y
Set objMatches = objRegExp.Execute(x.Value)
x.Offset(, 1).Value = Replace(Replace(Replace(Replace(objMatches(0), "у", ""), "-", ""), "№", ""), " ", "") & "_"
Next
Согласие есть продукт при полном непротивлении сторон
Добрый день. Можно еще таким паттерном попробовать:
Скрытый текст
Код
Sub GetCardNumberByRegExp()
Dim objRegExp As Object, objMatches As Object, strS As String, objC As Range
Set objRegExp = CreateObject("VBscript.RegExp")
With objRegExp
.Global = True
.IgnoreCase = True
.Pattern = "(\d{4})[ -]?(\d{4})[ -]?(\d{4})[ -]?(\d{4})[ -]?"
For Each objC In Selection
If IsNumeric(objC) Then
strS = CStr(Format(objC, "#####0"))
Else
strS = CStr(objC)
End If
If .Test(strS) Then
Set objMatches = .Execute(strS)
objC = .Replace(objMatches.Item(objMatches.Count - 1), "$1 $2 $3 $4")
End If
Next objC
End With
End Sub
Шерстим выделение и в каждой его ячейке заменяем введенный номер карты (даже среди прочего текста) на строку вида: "#### #### #### ####"
Sub KardDgt(s$)
Dim re, m, i&
Set re = CreateObject("VBScript.RegExp"): re.Pattern = "6500[\d -]{12,15}": re.Global = True
Set m = re.Execute(s)
For i = 0 To m.Count - 1
Debug.Print Replace(Replace(m(i), " ", ""), "-", "")
Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Доброе время суток. Вариант функцией. Просто вывод последовательности из 12 цифр, положение которых удовлетворяет шаблону.
Код
Public Function getCartNumber(ByVal fromText As String) As String
Static pReg As Object
Dim sNum As String, pItem As Object
If pReg Is Nothing Then
Set pReg = CreateObject("VBScript.RegExp")
pReg.Pattern = "\D(6500)\D?(\d{4})\D?(\d{4})\D?(\d{4})(?:\D|$)"
End If
For Each pItem In pReg.Execute(fromText)
sNum = pItem.SubMatches(0) & pItem.SubMatches(1) & pItem.SubMatches(2) & pItem.SubMatches(3)
Next
getCartNumber = sNum
End Function
Если номер карты только один в ячейке , то можно попробовать так
Код
Function iKarta(cell$)
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
.Pattern = "6500 ?-?\d{4} ?-?\d{4} ?-?\d{4}\b"
iKarta = .Execute(cell)(0)
End With
End Function
Андрей VG, спасибо, это именно то, что я хотел (без Replace, средствами RegExp вытащить нужный конечный результат) реализовать, но не хватило знаний.
Переделал вашу функцию в макрос:
Код
Sub getCartNumber()
Static pReg As Object
Dim sNum As String
If pReg Is Nothing Then
Set pReg = CreateObject("VBScript.RegExp")
pReg.Pattern = "\D(6500)\D?(\d{4})\D?(\d{4})\D?(\d{4})(?:\D|$)"
End If
For Each x In Selection
For Each k In pReg.Execute(x.Value)
sNum = k.SubMatches(0) & k.SubMatches(1) & k.SubMatches(2) & k.SubMatches(3)
Next
x.Offset(, 1).Value = sNum & "_"
Next
End Sub
pReg.Pattern = "6500\D?(\d{4})\D?(\d{4})\D?(\d{4})"
End If
For Each x In Selection
For Each k In pReg.Execute(x.Value)
sNum = "6500" & k.SubMatches(0) & k.SubMatches(1) & k.SubMatches(2)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
For Each x In Selection
sNum = ""
For Each k In pReg.Execute(x.Value)
Иначе, если в строке нет подстроки по шаблону, вы получите предыдущее состояние sNum, что не верно - нужно вывести пусто, как признак отсутствия номера карты.
Function myCarta$(text$)
text = Replace(Replace(text, "-", ""), " ", "")
With CreateObject("VBScript.RegExp"): .IgnoreCase = True: .Pattern = "на(?:карту№?)?(6500\d+)"
myCarta = .Execute(text)(0).Submatches(0)
End With
End Function