Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 02.10.2018, 00:46   #1
yaskin
Форумчанин
 
Регистрация: 10.01.2011
Сообщений: 112
По умолчанию Макрос для обработки категорий в прайсе

Помогите с макросом, который преобразовывал бы категории прайслиста из древовидного в строчный, с разделеним дерева категорий символом | (вертикальная черта).

Оригинальный прайс выглядит так

Screenshot_1.jpg

А нужно, чтобы выглядело так

Screenshot_2.jpg

Ссылка на оригинальный прайслист

Excel 2007
Для спасибо весы слева
yaskin вне форума Ответить с цитированием
Старый 02.10.2018, 11:13   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Разберетесь чо да как и куда
Код:
Sub asas()
    Dim Category(10) As String
    Dim r As Integer
    Dim r1 As Integer
    Dim lvl As Byte
    Dim j As Byte
    Dim line As String
    r1 = 2
    Category(0) = [a8]
    For r = 9 To 30
        lvl = Rows(r).OutlineLevel
        If Cells(r, "N") = "" Then
            Category(lvl - 1) = Cells(r, "A")
        Else
            line = ""
            For j = 1 To lvl - 1
                line = line & "|" & Category(j)
            Next j
            Sheets("Лист2").Cells(r1, "A") = line
            Sheets("Лист2").Cells(r1, "B") = Cells(r, "N")
            Sheets("Лист2").Cells(r1, "C") = Cells(r, "O")
            Sheets("Лист2").Cells(r1, "D") = Cells(r, "P")
            r1 = r1 + 1
        End If
    Next r
End Sub
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 02.10.2018, 12:03   #3
yaskin
Форумчанин
 
Регистрация: 10.01.2011
Сообщений: 112
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Разберетесь чо да как и куда
Код:
Sub asas()
    Dim Category(10) As String
    Dim r As Integer
    Dim r1 As Integer
    Dim lvl As Byte
    Dim j As Byte
    Dim line As String
    r1 = 2
    Category(0) = [a8]
    For r = 9 To 30
        lvl = Rows(r).OutlineLevel
        If Cells(r, "N") = "" Then
            Category(lvl - 1) = Cells(r, "A")
        Else
            line = ""
            For j = 1 To lvl - 1
                line = line & "|" & Category(j)
            Next j
            Sheets("Лист2").Cells(r1, "A") = line
            Sheets("Лист2").Cells(r1, "B") = Cells(r, "N")
            Sheets("Лист2").Cells(r1, "C") = Cells(r, "O")
            Sheets("Лист2").Cells(r1, "D") = Cells(r, "P")
            r1 = r1 + 1
        End If
    Next r
End Sub
Спасибо огромное
На оригинальном прайсе заработал вот такой код

Код:
Sub test()
    Dim Category(10) As String
    Dim r As Integer
    Dim r1 As Integer
    Dim lvl As Byte
    Dim j As Byte
    Dim line As String
    r1 = 2
    Category(0) = [a8]
    For r = 9 To 4500
        lvl = Rows(r).OutlineLevel
        If Cells(r, "N") = "" Then
            Category(lvl - 1) = Cells(r, "A")
        Else
            line = ""
            For j = 1 To lvl - 1
                line = line & "|" & Category(j)
            Next j
            Sheets("TDSheet").Cells(r1, "A") = line
            Sheets("TDSheet").Cells(r1, "B") = Cells(r, "N")
            Sheets("TDSheet").Cells(r1, "C") = Cells(r, "O")
            Sheets("TDSheet").Cells(r1, "D") = Cells(r, "P")
            r1 = r1 + 1
        End If
    Next r
End Sub
Только он и названия товаров заменяет категориями, а надо чтоб категории были в первой колонке, а названия товаров во второй

Screenshot_1.jpg
Для спасибо весы слева
yaskin вне форума Ответить с цитированием
Старый 02.10.2018, 12:40   #4
Казанский
Старожил
 
Аватар для Казанский
 
Регистрация: 31.12.2010
Сообщений: 2,133
По умолчанию

Александр, мне понравилась идея с массивом Category :up:
С массивами будет в сотню раз быстрее. Результат на новом листе.
Код:
Sub Ya()
Dim a(), np(), s$, i&, j&, k&, lvl&, cat$(1 To 10)
  a = Range("A8", Cells(Rows.Count, "A").End(xlUp)).Value2
  np = Range("N8:P8").Resize(UBound(a)).Value2
  ReDim b(1 To UBound(a), 1 To 5)
  For i = 1 To UBound(a)
    If IsEmpty(np(i, 1)) Then
      lvl = Rows(i + 7).OutlineLevel
      cat(lvl) = a(i, 1)
      s = vbNullString
    Else
      If Len(s) = 0 Then
        For j = 1 To lvl
          s = s & "|" & cat(j)
        Next
        s = Mid$(s, 2)
      End If
      k = k + 1
      b(k, 1) = s
      b(k, 2) = a(i, 1)
      b(k, 3) = np(i, 1)
      b(k, 4) = np(i, 2)
      b(k, 5) = np(i, 3)
    End If
  Next
  Worksheets.Add , ActiveSheet
  Columns(2).NumberFormat = "@"
  Range("A1").Resize(k, 5).Value2 = b
  Columns("A:E").AutoFit
End Sub
exceleved@yandex.ru Яндекс.Деньги: 410011500007619
Казанский вне форума Ответить с цитированием
Старый 02.10.2018, 13:18   #5
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Цитата:
Сообщение от yaskin Посмотреть сообщение
Только он и названия товаров заменяет категориями, а надо чтоб категории были в первой колонке, а названия товаров во второй
А зачем вы не создали "Лист2"? Макрос не должен выводить ничего наTDSheet

Код:
Sub asas()
    Dim Category(10) As String
    Dim r As Integer
    Dim r1 As Integer
    Dim lvl As Byte
    Dim j As Byte
    Dim line As String
    Dim Ncell
    r1 = 2
    Category(0) = [a8]
    For r = 9 To 30
        lvl = Rows(r).OutlineLevel
        Set Ncell = Cells(r, "N")
        
        If Trim(Ncell) = "" And (Ncell.MergeCells) Then
            Category(lvl - 1) = Cells(r, "A")
        Else
            line = ""
            For j = 0 To lvl - 1
                line = line & "|" & Category(j)
            Next j
            line = Mid(line, 2)
            line = Left(line, Len(line) - 1)
            
            Sheets("Лист2").Cells(r1, "A") = line
            Sheets("Лист2").Cells(r1, "B") = Cells(r, "A")
            Sheets("Лист2").Cells(r1, "C") = Cells(r, "N")
            Sheets("Лист2").Cells(r1, "D") = Cells(r, "O")
            Sheets("Лист2").Cells(r1, "E") = Cells(r, "P")
            r1 = r1 + 1
        End If
    Next r
End Sub
Казанский
работет намного быстрее. Спасибо.
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 03.10.2018, 00:15   #6
yaskin
Форумчанин
 
Регистрация: 10.01.2011
Сообщений: 112
По умолчанию

Спасибо всем. Заработало
Закрыто
Для спасибо весы слева
yaskin вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Нестандартный макрос для обработки таблицы Олег Никитин Microsoft Office Excel 5 08.03.2012 13:43
Нужна функция(Макрос) для вывода номеров и категорий в таблице alexp21 Microsoft Office Excel 4 26.09.2011 23:32
Макрос для обработки прайсов nondescript Microsoft Office Excel 11 24.08.2010 23:51
надо: макрос для обработки данных poll69 Microsoft Office Excel 2 06.02.2010 17:25
макрос для обработки результатов тестирования prostoklassnik Microsoft Office Excel 12 05.11.2009 13:35