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
|
