Макрос извлекающий отдельную информацию из ячеек

[denn1812]

Здравствуйте,
Нужна очень помощь Ваша.
Приложил файл.
В нем есть таблица. Мне нужно из таблицы делать плоскую таблицу.
Пример плоской на другом листе.
Т.е мне нужно выдирать из ячеек определенную информацию.
Например в ячейке E25, там 2 разных счета, а в F25 их 4.
В идеале было бы здорово чтобы все это делалось автоматически.
т.е выдернуты счета из ячеек, обороты счетов (ОК,ОД,СДН) стоящие перед счетом, движение F00,F09 и т.д.
Просто у меня таких таблиц оч много, и было бы супер хоть как нибудь облегчить себе работу.

Спасибо заранее,

[Казанский]

Запускайте с первого листа. Адреса ячеек вставляются как гиперссылки.

Sub denn1812()
Dim u(), r&, c&, schet, r1&, sh As Worksheet, re As Object, x, h
u = ActiveSheet.UsedRange.Value
h = "#'" & Replace$(ActiveSheet.Name, "'", "''") & "'!"  'заготовка для гиперссылки
Set sh = Sheets("Плоская табл")
r1 = 3                                                   'строка, к кот. начинать вывод
schet = u(6, 1)
Set re = CreateObject("vbscript.regexp")
re.Global = True
re.ignorecase = True
re.Pattern = "([a-zа-я]+) Сч. (\d+)"
For r = 7 To UBound(u)                                   'цикл по строкам
  If Not IsEmpty(u(r, 1)) Then schet = u(r, 1)
  For c = 5 To UBound(u, 2)                              'цикл по столбцам
    For Each x In re.Execute(u(r, c))
'      sh.Cells(r1, 3) = Cells(r, c).Address(0, 0)       'простой ввод адреса ячейки
      sh.Hyperlinks.Add sh.Cells(r1, 3), "", h & Cells(r, c).Address, , Cells(r, c).Address(0, 0)
      sh.Cells(r1, 4) = x.submatches(1)
      sh.Cells(r1, 5) = x.submatches(0)
      sh.Cells(r1, 7) = schet
      sh.Cells(r1, 8) = u(4, c)
      r1 = r1 + 1
    Next
  Next
Next
End Sub

[Казанский]

del.......

[denn1812]

Спасибо тебе большое, очень рад все работает!!отблагодарю позже.

А можно чуть апдейтить код?
Есть много ячеек где написано "В указанную ячейку данные из Системы не выгружаются" или содержат эту надпись. Хотелось бы чтобы эти ячейки он не пропускал, а тоже имел ввиду и писал "В указанную ячейку данные из Системы не выгружаются" под (r1, 4) столбцом, ну и пусть номер счета (в плоской таблице "счет" сохранится, да и другие тоже если это облегчит работу).

[denn1812]

Уже не надо, сам сделал.спасибо

[Казанский]

Точно сам!:D
http://www.planetaexcel.ru/forum/ind...ID=1&TID=56663

[denn1812]

:D ну сам догадался где еше спросить))) просто срочно надо было

[denn1812]

Снова к Вам обращаюсь.
Вот вы сделали гиперссылки. А можно сделать чтобы вся сторока окрашивалась в тот цвет в котором находится ячейка на которую ссылается гиперссылка?

[Казанский]

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

      sh.Rows(r1).Interior.Color = Cells(r, c).Interior.Color

[denn1812]

Большое большое спасибо!!!
больше неудобно спрашивать уже. последний вопрос.
А как добавить еще один критерий поиска. Например в ячейке с "([a-zа-я]+) Сч. (\d+)" есть слово класс пробел и (\d+)(цифры).... я долго мучался так и не вышло. я добавлял второе условие типо

Sub denn1812()
    Dim u(), r&, c&, schet, r1&, sh As Worksheet, re As Object, x, h
    u = ActiveSheet.UsedRange.Value
    h = "#'" & Replace$(ActiveSheet.Name, "'", "''") & "'!"  'çàãîòîâêà äëÿ ãèïåðññûëêè
    Set sh = Sheets("Ïëîñêàÿ òàáë")
    r1 = 4                                                   'ñòðîêà, ê êîò. íà÷èíàòü âûâîä
    schet = u(6, 1)
    Set re = CreateObject("vbscript.regexp")
    re.Global = True
    re.ignorecase = True
 
    For r = 19 To UBound(u)                                   'öèêë ïî ñòðîêàì
        If Not IsEmpty(u(r, 1)) Then schet = u(r, 1)
        For c = 6 To UBound(u, 2)
        re.Pattern = "([a-za-я]+) Сч. (\d+)"              'öèêë ïî ñòîëáöàì
            For Each x In re.Execute(u(r, c))
                '      sh.Cells(r1, 4) = Cells(r, c).Address(0, 0)       'ïðîñòîé ââîä àäðåñà ÿ÷åéêè
                sh.Rows(r1).Interior.Color = Cells(r, c).Interior.Color
                sh.Hyperlinks.Add sh.Cells(r1, 4), "", h & Cells(r, c).Address, , Cells(r, c).Address(0, 0)
                sh.Rows(r1).Interior.Color = Cells(r, c).Interior.Color
                sh.Cells(r1, 5) = x.submatches(1)
                sh.Cells(r1, 7) = x.submatches(0)
                sh.Cells(r1, 16) = schet
                sh.Cells(r1, 17) = u(16, c)
                r1 = r1 + 1
          Next
          re.Pattern = "класс (\d+)"
          For Each x In re.Execute(u(r, c))
                '      sh.Cells(r1, 4) = Cells(r, c).Address(0, 0)       'ïðîñòîé ââîä àäðåñà ÿ÷åéêè
                sh.Rows(r1).Interior.Color = Cells(r, c).Interior.Color
                sh.Hyperlinks.Add sh.Cells(r1, 4), "", h & Cells(r, c).Address, , Cells(r, c).Address(0, 0)
                   sh.Rows(r1).Interior.Color = Cells(r, c).Interior.Color
                sh.Cells(r1, 13) = x.submatches(0)
                ' sh.Cells(r1, 7) = x.submatches(0)
                sh.Cells(r1, 16) = schet
                sh.Cells(r1, 17) = u(16, c)
                r1 = r1 + 1
            Next

        Next

    Next
End Sub

но тут что то не то, он класс выводит, но что то другое нет. в общем как то через одно место.
Или такое условие "по виду движения X02, Y02" или по виду движению по виду движения Y14, Y15", нужно что бы X02, Y02 выводил куда ниб

Буду еще раз очень очень признателен если поможете))