Всем привет. Пожалуй перейду сразу в общем имеется скрипт (писал не я, помогли) который по определенному признаку (коды оператора, которые указаны в массиве) отделяет мобильные номера в таблице от городских. Скрипт работает отлично, но так как он опирается на скобки возле кода (050), иногда случаются ложные срабатывания. Я хотел бы попросить помощи у тех кто разбирается в VBA, помогите пожалуйста переделать скрипт так, что бы он детектировал номера не по скобочкам, а по следующему регулярному выражению:
Единственное, я не совсем уверен в верности регулярки, кажется я ошибся с окончанием строки (\b).
Сам скрипт: [vba]
Код
Public Sub QWERT() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB M = Array(39, 50, 63, 66, 67, 68, 91, 92, 93, 94, 95, 96, 97, 98, 99)
'закидываем в словарь префиксы For R = 0 To UBound(M) T("(0" & M(R) & ")") = 1 Next R
'считываем в маассив данные With Ëèñò1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2)
'перебираем все строки массива For R = 1 To UBound(M) ' отделяеем название фирмы If InStr(1, M(R, 1), ",") > 0 Then C = Split(M(R, 1), ",")(0) RZ(R, 1) = C RZ(R, 2) = Replace(M(R, 1), C & ",", "") Else RZ(R, 1) = M(R, 1) End If RZ(R, 3) = M(R, 2) ' ищем мобильные операторы
U = Split(M(R, 3), ",") For i = 0 To UBound(U) Debug.Print i, UBound(U), U(i), R If T.Exists(Left(U(i), 5)) Then RZ(R, 4) = IIf(RZ(R, 4) = "", U(i), RZ(R, 4) & "," & U(i)) Else RZ(R, 5) = IIf(RZ(R, 5) = "", U(i), RZ(R, 5) & "," & U(i)) End If Next i For i = 4 To UBound(M, 2) RZ(R, i + 2) = M(R, i) Next i Next R Worksheets.Add Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ Cells.Columns.AutoFit Cells.Rows.AutoFit
End Sub
[/vba]
Кстати, если это возможно было бы кайфово, если бы при отборе названий фирмы, можно было бы опираться не на первую запятую а на последнюю в строке.
Большое спасибо.
Всем привет. Пожалуй перейду сразу в общем имеется скрипт (писал не я, помогли) который по определенному признаку (коды оператора, которые указаны в массиве) отделяет мобильные номера в таблице от городских. Скрипт работает отлично, но так как он опирается на скобки возле кода (050), иногда случаются ложные срабатывания. Я хотел бы попросить помощи у тех кто разбирается в VBA, помогите пожалуйста переделать скрипт так, что бы он детектировал номера не по скобочкам, а по следующему регулярному выражению:
Единственное, я не совсем уверен в верности регулярки, кажется я ошибся с окончанием строки (\b).
Сам скрипт: [vba]
Код
Public Sub QWERT() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB M = Array(39, 50, 63, 66, 67, 68, 91, 92, 93, 94, 95, 96, 97, 98, 99)
'закидываем в словарь префиксы For R = 0 To UBound(M) T("(0" & M(R) & ")") = 1 Next R
'считываем в маассив данные With Ëèñò1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2)
'перебираем все строки массива For R = 1 To UBound(M) ' отделяеем название фирмы If InStr(1, M(R, 1), ",") > 0 Then C = Split(M(R, 1), ",")(0) RZ(R, 1) = C RZ(R, 2) = Replace(M(R, 1), C & ",", "") Else RZ(R, 1) = M(R, 1) End If RZ(R, 3) = M(R, 2) ' ищем мобильные операторы
U = Split(M(R, 3), ",") For i = 0 To UBound(U) Debug.Print i, UBound(U), U(i), R If T.Exists(Left(U(i), 5)) Then RZ(R, 4) = IIf(RZ(R, 4) = "", U(i), RZ(R, 4) & "," & U(i)) Else RZ(R, 5) = IIf(RZ(R, 5) = "", U(i), RZ(R, 5) & "," & U(i)) End If Next i For i = 4 To UBound(M, 2) RZ(R, i + 2) = M(R, i) Next i Next R Worksheets.Add Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ Cells.Columns.AutoFit Cells.Rows.AutoFit
End Sub
[/vba]
Кстати, если это возможно было бы кайфово, если бы при отборе названий фирмы, можно было бы опираться не на первую запятую а на последнюю в строке.
Я тут подшаманил немного и переработал исходный код (пару мануалов + помощь) и получилось вполне сносно и полностью подходит под мои нужды. Но возникла небольшая проблема. Вместо того, что-бы таблица расширялась на еще один доп. столбец, наоборот, замещает данные в ячейках соседнего, так как в синтасисе vba я не особо силен, то не смог детектировать проблему. Если не затруднит, посмотрите пожалуйста.
[vba]
Код
Attribute VB_Name = "SplitNumber" Option Explicit Private Function мобила(S As Variant) Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer S = Replace(S, " ", "") S = Replace(S, "-", "") Sl = "" ReDim X(1) As String bRes = False Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.IgnoreCase = True RegExp.Pattern = "\(?(039|050|063|066|067|068|091|092|093|094|095|096|097|098|099)\)?(\d{3})(\d{2})(\d{2}),?" bRes = RegExp.test(S) If bRes Then Set oMatches = RegExp.Execute(S) ' ReDim X(oMatches.Count) Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3) For n = 1 To oMatches.Count - 1 Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3) Next S = RegExp.Replace(S, "") End If X(0) = Sl: X(1) = "'" & S мобила = X End Function Private Function cityNumber(S As Variant) Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer S = Replace(S, " ", "") S = Replace(S, "-", "") S = Replace(S, "(", "") S = Replace(S, ")", "") S = Replace(S, ",", "") Sl = "" ReDim X(1) As String bRes = False Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.IgnoreCase = True RegExp.Pattern = ",?(\d{3})(\d{3})(\d{2})(\d{2}),?" bRes = RegExp.test(S) If bRes Then Set oMatches = RegExp.Execute(S) ' ReDim X(oMatches.Count) Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3) For n = 1 To oMatches.Count - 1 Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3) Next S = RegExp.Replace(S, "") End If X(0) = Sl: X(1) = "'" & S cityNumber = X End Function Private Function Town(S As Variant) Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer Sl = "" ReDim X(1) As String bRes = False Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.IgnoreCase = True RegExp.Pattern = "\d{5},(.*?)," bRes = RegExp.test(S) If bRes Then Set oMatches = RegExp.Execute(S) ' ReDim X(oMatches.Count) Sl = oMatches(0).subMatches(0) For n = 1 To oMatches.Count - 1 Sl = Sl & ", " & oMatches(n).subMatches(0) Next S = RegExp.Replace(S, "") End If X(0) = Sl: X(1) = "'" & S Town = X End Function Public Sub QWERT() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB 'считываем в маассив данные With Лист1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2) 'перебираем все строки массива For R = 1 To UBound(M) ' отделяеем название фирмы If InStr(1, M(R, 1), ",") > 0 Then C = Split(M(R, 1), ",")(0) RZ(R, 1) = C RZ(R, 2) = Replace(M(R, 1), C & ",", "") Else RZ(R, 1) = M(R, 1) End If RZ(R, 3) = M(R, 2) RZ(R, 5) = M(R, 2) ' ищем города T = Town(M(R, 2)) RZ(R, 3) = T(0) RZ(R, 4) = T(1) ' ищем мобильные операторы U = мобила(M(R, 3)) C = cityNumber(M(R, 3)) RZ(R, 5) = U(0) RZ(R, 6) = C(0) For i = 5 To UBound(M, 2) RZ(R, i + 2) = M(R, i) Next i Next R Worksheets.Add Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ Cells.Columns.AutoFit Cells.Rows.AutoFit End Sub
[/vba]
Я тут подшаманил немного и переработал исходный код (пару мануалов + помощь) и получилось вполне сносно и полностью подходит под мои нужды. Но возникла небольшая проблема. Вместо того, что-бы таблица расширялась на еще один доп. столбец, наоборот, замещает данные в ячейках соседнего, так как в синтасисе vba я не особо силен, то не смог детектировать проблему. Если не затруднит, посмотрите пожалуйста.
[vba]
Код
Attribute VB_Name = "SplitNumber" Option Explicit Private Function мобила(S As Variant) Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer S = Replace(S, " ", "") S = Replace(S, "-", "") Sl = "" ReDim X(1) As String bRes = False Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.IgnoreCase = True RegExp.Pattern = "\(?(039|050|063|066|067|068|091|092|093|094|095|096|097|098|099)\)?(\d{3})(\d{2})(\d{2}),?" bRes = RegExp.test(S) If bRes Then Set oMatches = RegExp.Execute(S) ' ReDim X(oMatches.Count) Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3) For n = 1 To oMatches.Count - 1 Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3) Next S = RegExp.Replace(S, "") End If X(0) = Sl: X(1) = "'" & S мобила = X End Function Private Function cityNumber(S As Variant) Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer S = Replace(S, " ", "") S = Replace(S, "-", "") S = Replace(S, "(", "") S = Replace(S, ")", "") S = Replace(S, ",", "") Sl = "" ReDim X(1) As String bRes = False Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.IgnoreCase = True RegExp.Pattern = ",?(\d{3})(\d{3})(\d{2})(\d{2}),?" bRes = RegExp.test(S) If bRes Then Set oMatches = RegExp.Execute(S) ' ReDim X(oMatches.Count) Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3) For n = 1 To oMatches.Count - 1 Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3) Next S = RegExp.Replace(S, "") End If X(0) = Sl: X(1) = "'" & S cityNumber = X End Function Private Function Town(S As Variant) Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer Sl = "" ReDim X(1) As String bRes = False Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.IgnoreCase = True RegExp.Pattern = "\d{5},(.*?)," bRes = RegExp.test(S) If bRes Then Set oMatches = RegExp.Execute(S) ' ReDim X(oMatches.Count) Sl = oMatches(0).subMatches(0) For n = 1 To oMatches.Count - 1 Sl = Sl & ", " & oMatches(n).subMatches(0) Next S = RegExp.Replace(S, "") End If X(0) = Sl: X(1) = "'" & S Town = X End Function Public Sub QWERT() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB 'считываем в маассив данные With Лист1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2) 'перебираем все строки массива For R = 1 To UBound(M) ' отделяеем название фирмы If InStr(1, M(R, 1), ",") > 0 Then C = Split(M(R, 1), ",")(0) RZ(R, 1) = C RZ(R, 2) = Replace(M(R, 1), C & ",", "") Else RZ(R, 1) = M(R, 1) End If RZ(R, 3) = M(R, 2) RZ(R, 5) = M(R, 2) ' ищем города T = Town(M(R, 2)) RZ(R, 3) = T(0) RZ(R, 4) = T(1) ' ищем мобильные операторы U = мобила(M(R, 3)) C = cityNumber(M(R, 3)) RZ(R, 5) = U(0) RZ(R, 6) = C(0) For i = 5 To UBound(M, 2) RZ(R, i + 2) = M(R, i) Next i Next R Worksheets.Add Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ Cells.Columns.AutoFit Cells.Rows.AutoFit End Sub
Ну, то есть о чём я и говорил. "Всё работает отлично, но как-то не так, как нужно" По идее, вам продемонстрировали пример без регулярок - зачем вы будете влезать с ними? И с "последней запятой" тоже - можно было просто в хелпе посмотреть, что есть InStrRev... Код я вам поправил на основе исходного, а не вашего, попробуйте хоть в этом варианте разобраться... И да, "вид предприятия" тоже неплохо бы повесить на словарь, чтобы в него не отбирались всякие филиалы и пр.
[vba]
Код
Option Explicit
Public Sub MyTest1() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB MB = Array("039", "050", "063", "066", "067", "068", "091", "092", "093", "094", "095", "096", "097", "098", "099")
For R = 0 To UBound(MB) T("(" & MB(R)) = 1 Next R
With Лист1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To 3)
For R = 1 To UBound(M)
i = InStrRev(M(R, 1), ",") If i > 0 Then RZ(R, 1) = Left(M(R, 1), i - 1) RZ(R, 2) = Trim(Mid(M(R, 1), i + 1)) Else RZ(R, 1) = M(R, 1) End If
U = Split(M(R, 3), ",") For i = 0 To UBound(U) If T.Exists(Left(Trim(U(i)), 4)) Then RZ(R, 3) = IIf(RZ(R, 3) = "", U(i), RZ(R, 3) & "," & U(i)) End If Next i
И, до кучи, - доработка его же под ваши новые требования. И зачем напрягаться с городскими телефонами? Они ищутся по принципу "всё, что не мобильное" А адрес можно было бы тоже просто поделить по принципу "до второй запятой и после", но там ещё дописана проверка на отсутствие индекса...
[vba]
Код
Public Sub MyTest2() Dim R, C, i, j Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB MB = Array("039", "050", "063", "066", "067", "068", "091", "092", "093", "094", "095", "096", "097", "098", "099")
For R = 0 To UBound(MB) T("(" & MB(R)) = 1 Next R
With Лист1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To 6)
For R = 1 To UBound(M)
i = InStrRev(M(R, 1), ",") If i > 0 Then RZ(R, 1) = Left(M(R, 1), i - 1) RZ(R, 2) = Trim(Mid(M(R, 1), i + 1)) Else RZ(R, 1) = M(R, 1) End If
U = Split(M(R, 3), ",") For i = 0 To UBound(U) If T.Exists(Left(LTrim(U(i)), 4)) Then RZ(R, 3) = IIf(RZ(R, 3) = "", U(i), RZ(R, 3) & "," & U(i)) Else RZ(R, 4) = IIf(RZ(R, 4) = "", U(i), RZ(R, 4) & "," & U(i)) End If Next i
RZ(R, 5) = M(R, 2) i = InStr(M(R, 2), ",") If i > 0 Then j = InStr(i + 1, M(R, 2), ",") If j > 0 Then RZ(R, 5) = Mid(M(R, 2), i + 1, j - i - 1) RZ(R, 6) = LTrim(Mid(M(R, 2), j + 1)) Else RZ(R, 5) = Left(M(R, 2), i - 1) RZ(R, 6) = LTrim(Mid(M(R, 2), i + 1)) End If End If
И да, номера телефонов можно тоже переделать под шаблон. Допишем код:
[vba]
Код
Function PhoneTemplate(c As String) Dim s s = Replace(Replace(Replace(Replace(Replace(c, " ", ""), "-", ""), "(", ""), ")", ""), ",", "") PhoneTemplate = IIf(Len(s) <> 10, s, "(" & Mid(s, 1, 3) & ") " & Mid(s, 4, 3) & "-" & Mid(s, 7, 2) & "-" & Mid(s, 9, 2)) End Function
Public Sub MyTest2() '... For i = 0 To UBound(U) C = PhoneTemplate(U(i)) If T.Exists(Left(LTrim(U(i)), 4)) Then RZ(R, 3) = IIf(RZ(R, 3) = "", C, RZ(R, 3) & ", " & C) Else RZ(R, 4) = IIf(RZ(R, 4) = "", C, RZ(R, 4) & ", " & C) End If Next i '...
[/vba]
Ну, то есть о чём я и говорил. "Всё работает отлично, но как-то не так, как нужно" По идее, вам продемонстрировали пример без регулярок - зачем вы будете влезать с ними? И с "последней запятой" тоже - можно было просто в хелпе посмотреть, что есть InStrRev... Код я вам поправил на основе исходного, а не вашего, попробуйте хоть в этом варианте разобраться... И да, "вид предприятия" тоже неплохо бы повесить на словарь, чтобы в него не отбирались всякие филиалы и пр.
[vba]
Код
Option Explicit
Public Sub MyTest1() Dim R, C, i Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB MB = Array("039", "050", "063", "066", "067", "068", "091", "092", "093", "094", "095", "096", "097", "098", "099")
For R = 0 To UBound(MB) T("(" & MB(R)) = 1 Next R
With Лист1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To 3)
For R = 1 To UBound(M)
i = InStrRev(M(R, 1), ",") If i > 0 Then RZ(R, 1) = Left(M(R, 1), i - 1) RZ(R, 2) = Trim(Mid(M(R, 1), i + 1)) Else RZ(R, 1) = M(R, 1) End If
U = Split(M(R, 3), ",") For i = 0 To UBound(U) If T.Exists(Left(Trim(U(i)), 4)) Then RZ(R, 3) = IIf(RZ(R, 3) = "", U(i), RZ(R, 3) & "," & U(i)) End If Next i
И, до кучи, - доработка его же под ваши новые требования. И зачем напрягаться с городскими телефонами? Они ищутся по принципу "всё, что не мобильное" А адрес можно было бы тоже просто поделить по принципу "до второй запятой и после", но там ещё дописана проверка на отсутствие индекса...
[vba]
Код
Public Sub MyTest2() Dim R, C, i, j Dim OD: Set OD = CreateObject("Scripting.Dictionary") Dim T: Set T = CreateObject("Scripting.Dictionary") Dim M(), RZ(), U() As String Dim MB MB = Array("039", "050", "063", "066", "067", "068", "091", "092", "093", "094", "095", "096", "097", "098", "099")
For R = 0 To UBound(MB) T("(" & MB(R)) = 1 Next R
With Лист1 M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ReDim RZ(1 To UBound(M), 1 To 6)
For R = 1 To UBound(M)
i = InStrRev(M(R, 1), ",") If i > 0 Then RZ(R, 1) = Left(M(R, 1), i - 1) RZ(R, 2) = Trim(Mid(M(R, 1), i + 1)) Else RZ(R, 1) = M(R, 1) End If
U = Split(M(R, 3), ",") For i = 0 To UBound(U) If T.Exists(Left(LTrim(U(i)), 4)) Then RZ(R, 3) = IIf(RZ(R, 3) = "", U(i), RZ(R, 3) & "," & U(i)) Else RZ(R, 4) = IIf(RZ(R, 4) = "", U(i), RZ(R, 4) & "," & U(i)) End If Next i
RZ(R, 5) = M(R, 2) i = InStr(M(R, 2), ",") If i > 0 Then j = InStr(i + 1, M(R, 2), ",") If j > 0 Then RZ(R, 5) = Mid(M(R, 2), i + 1, j - i - 1) RZ(R, 6) = LTrim(Mid(M(R, 2), j + 1)) Else RZ(R, 5) = Left(M(R, 2), i - 1) RZ(R, 6) = LTrim(Mid(M(R, 2), i + 1)) End If End If
И да, номера телефонов можно тоже переделать под шаблон. Допишем код:
[vba]
Код
Function PhoneTemplate(c As String) Dim s s = Replace(Replace(Replace(Replace(Replace(c, " ", ""), "-", ""), "(", ""), ")", ""), ",", "") PhoneTemplate = IIf(Len(s) <> 10, s, "(" & Mid(s, 1, 3) & ") " & Mid(s, 4, 3) & "-" & Mid(s, 7, 2) & "-" & Mid(s, 9, 2)) End Function
Public Sub MyTest2() '... For i = 0 To UBound(U) C = PhoneTemplate(U(i)) If T.Exists(Left(LTrim(U(i)), 4)) Then RZ(R, 3) = IIf(RZ(R, 3) = "", C, RZ(R, 3) & ", " & C) Else RZ(R, 4) = IIf(RZ(R, 4) = "", C, RZ(R, 4) & ", " & C) End If Next i '...