Макрос для вывода всех дополнительных услуг абонента

[zenner]

Добрый день! У меня есть лог файл выведенный АТС - 106(servicii).txt. Я открываю его через макрос сделаный пользователем EducatedFool Sample__1.rar. Данный макрос раскладывает по дополнительным услугам все тел. номера из лог-файла!
Но один и тотже номер повторяется сразу в нескольких колонках с услугами так как он может иметь одновременно несколько доп.услуг(клип, пароль,9 кат итд.) Как можно переделать данный макрос чтобы он выводил номер и все услуги которые он имеет???
Вот расшифровки услуг:
CLIP - ipt-2 и ant-1
CLIR - clir-1
CAW - als-1 и caw-1
Пароль - als-1 и ccb-2
CFUV - als-1 и cfuv-1
CFNRV - als-1 и cfnrv-1
9 категория - tcl-9
3 категория - tcl-3


СПАСИБО!

[EducatedFool]

А где пример того, что должно получиться?

Как должен выглядеть результат?
в первом столбце - номера, а в остальных столбцах (с заголовками в виде названия услуг) - какие-то отметки о наличии услуги?

[zenner]

Сообщение от EducatedFool

А где пример того, что должно получиться?

Как должен выглядеть результат?
в первом столбце - номера, а в остальных столбцах (с заголовками в виде названия услуг) - какие-то отметки о наличии услуги?

Вот так наверное будет лучше всего:
Безымянный.jpg

[EducatedFool]

Вот что получилось:



Проверяйте.

Номера без услуг удаляются последней строкой в макросе.

(добавлено)
Кстати, до этого ваш макрос работал неправильно...

В начале макроса есть строка

Dim tbi1 As Boolean, oba55 As Boolean, tbo1 As Boolean, nc As Boolean

Раз уж вы самостоятельно добавили несколько столбцов, то надо было аналогично прописать новые переменные, присвоив им тип Boolean.
Для проверок типа If tcl3 Then это не критично, а вот двойные проверки вроде If als1 And cfuv1 Then ИНОГДА (не всегда) возвращают неверный результат.
Почему? Всё просто - запустите для проверки эти строки кода:

msgbox cbool(4 and 3) ' так вычислялось раньше - в расчётах участвовали числовые значения
msgbox cbool(true and true) ' а теперь всё правильно - обрабатываются логические значения

сейчас я учёл этот нюанс - автоматически назначая переменным тип Boolean,
заменив als1 = InStr(1, t, "als-1")
на als1 = InStr(1, t, "als-1") > 0

Вот новая версия кода:

Sub Поиск_AXE_10()
    On Error Resume Next: Application.ScreenUpdating = False
    Filename = GetTXTFileName: If Filename = "" Then Exit Sub
    'Filename = "C:\Documents and Settings\Admin\Рабочий стол\106(servicii).txt"

    Set fso = CreateObject("scripting.filesystemobject")    ' считываем текст из файла
    Set ts = fso.OpenTextFile(Filename, 1, True): txt = ts.ReadAll: ts.Close

    arr = Split(txt, vbNewLine & "        " & "END" & vbNewLine)

    For i = LBound(arr) To UBound(arr)
        t = arr(i)    ' текст одной записи
        als1 = InStr(1, t, "als-1") > 0  ' ищем  als-1
        ccb2 = InStr(1, t, "ccb-2") > 0  ' ищем  ccb-2
        caw1 = InStr(1, t, "caw-1") > 0  ' ищем  caw-1
        ipt2 = InStr(1, t, "ipt-2") > 0  ' ищем  ipt-2
        ant1 = InStr(1, t, "ant-1") > 0  ' ищем  ant-1
        tcl9 = InStr(1, t, "tcl-9") > 0  ' ищем  tcl-9
        clir1 = InStr(1, t, "clir-1") > 0  ' ищем  clir-1
        tcl3 = InStr(1, t, "tcl-3") > 0  ' ищем  tcl-3
        cfuv1 = InStr(1, t, "cfuv-1") > 0  ' ищем  cfuv-1
        CFNRV = InStr(1, t, "cfnrv-1") > 0  ' ищем  cfnrv-1
        nc = InStr(1, t, "nc") > 0  ' ищем  nc

        With Range("a" & Rows.Count).End(xlUp).Offset(1).EntireRow
            .Cells(1) = Номер(t)
            If als1 And ccb2 Then ДобавитьУслугу .EntireRow, "Пароль"    'Пароль - als-1 и ccb-2
            If ipt2 And ant1 Then ДобавитьУслугу .EntireRow, "CLIP"    'CLIP - ipt-2 и ant-1
            If tcl9 Then ДобавитьУслугу .EntireRow, "9 кат"   '9 категория -tcl - 9
            If tcl3 Then ДобавитьУслугу .EntireRow, "3 кат"   '3 категория -tcl - 3
            If als1 And caw1 Then ДобавитьУслугу .EntireRow, "CAW"   'CAW - als-1 и caw-1
            'If nc Then ДобавитьУслугу .Range, "nc"
            If als1 And cfuv1 Then ДобавитьУслугу .EntireRow, "CFUV"    'CFUV - als-1 и cfuv-1
            If als1 And cfnrv1 Then ДобавитьУслугу .EntireRow, "CFNRV"   'CFNRV - als-1 и cfnrv-1
            If clir1 Then ДобавитьУслугу .EntireRow, "clir"    'clir -clir - 1
        End With
    Next i
    
    ' если надо убрать строки без услуг
    Range([a3], Range("a" & Rows.Count).End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

[zenner]

Спасибо большое за помощь! Этот макрос на много облегчит мне работу!Спасибо!

[zenner]

Добрый день! До сих пор макрос работал на моем компьютере а сегодня перестал! Сам макрос не поврежден так как на другом компе работает а у меня не хочет! Переустанавливал оффис с полной очисткой но не помогло!
Подскажите пожалуйста что в системе могло повлиять на работу макроса? Когда я выполняю макрос ничего не происходит(не выводятся никакие данные). Спасибо!

[zenner]

нашел на сайте что нужно проверить Activex которые использует макрос,только не знаю как это сделать. Что еще проверить в Windows XP?

[EducatedFool]

нашел на сайте что нужно проверить Activex которые использует макрос

где это вы нашли?
Если бы что-то надо было проверить - я бы вам сразу сказал об этом.

Ничего проверять не надо - макрос ведь работает, что ещё нужно?

[zenner]

Я нажимаю на кнопку "Поиск", выбираю свой текстовый файл который нужно обработать но ничего не проискодит и никакие ошибки не выводятся.
Про activeX нашел на http://sysadmins.ru/topic62453.html

[EducatedFool]

Уберите директиву On Error Resume Next - и ошибки будут выводиться.

Может, формат файла изменился, может, ещё что-то. Проверять надо, тестировать.
activeX тут ни при чем, однозначно.