Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Создание листов с данными на основе общей таблицы - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание листов с данными на основе общей таблицы (Макросы/Sub)
Создание листов с данными на основе общей таблицы
Templin57 Дата: Среда, 30.03.2022, 20:36 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день,
Имеется таблица с данными, необходимо создать листы с наименованием соответствующие определенному полю в таблице.
На листе отразить ту же самую таблицу, только содержащую определенное значение в поле.

Не понятно написано :)

На примере (во вложении) есть таблица с заказами, во второй колонке (Продукт) перечислены заказанные продукты.
Необходимо создать N-ое количество листов, которое равняется уникальным наименованиям в колонке "Продукт". В каждый созданный лист переносится таблица где отражается информация по 1 виду продукта.

Из хотелок)...В колонке "F" выпадающий список, хотелось, чтобы он тоже работал во вновь созданных листах.

Во вложении 2 листа:
1. Основная таблица;
2. Пример одного листа, что должно получиться.

Пробовал экспериментировать с кодом:

[vba]
Код
Sub parse_data()
'Update by Extendoffice 2018/3/2
    Dim xRCount As Long
    Dim xSht As Worksheet
    Dim xNSht As Worksheet
    Dim I As Long
    Dim xTRrow As Integer
    Dim xCol As New Collection
    Dim xTitle As String
    Dim xSUpdate As Boolean
    Set xSht = ActiveSheet
    On Error Resume Next
    xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
    xTitle = "A1:H1"
    xTRrow = xSht.Range(xTitle).Cells(1).Row
    For I = 2 To xRCount
        Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
    Next
    xSUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    For I = 1 To xCol.Count
        Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
        Set xNSht = Nothing
        Set xNSht = Worksheets(CStr(xCol.Item(I)))
        If xNSht Is Nothing Then
            Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
            xNSht.Name = CStr(xCol.Item(I))
        Else
            xNSht.Move , Sheets(Sheets.Count)
        End If
        xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
        xNSht.Columns.AutoFit
    Next
    xSht.AutoFilterMode = False
    xSht.Activate
    Application.ScreenUpdating = xSUpdate
End Sub
[/vba]

Листы создать получилось, шапку таблицы перенес...но данные так и не смог((

Спасибо заранее за помощь!
К сообщению приложен файл: 4320366.xls(31.5 Kb)


Сообщение отредактировал Templin57 - Среда, 30.03.2022, 21:00
 
Ответить
СообщениеДобрый день,
Имеется таблица с данными, необходимо создать листы с наименованием соответствующие определенному полю в таблице.
На листе отразить ту же самую таблицу, только содержащую определенное значение в поле.

Не понятно написано :)

На примере (во вложении) есть таблица с заказами, во второй колонке (Продукт) перечислены заказанные продукты.
Необходимо создать N-ое количество листов, которое равняется уникальным наименованиям в колонке "Продукт". В каждый созданный лист переносится таблица где отражается информация по 1 виду продукта.

Из хотелок)...В колонке "F" выпадающий список, хотелось, чтобы он тоже работал во вновь созданных листах.

Во вложении 2 листа:
1. Основная таблица;
2. Пример одного листа, что должно получиться.

Пробовал экспериментировать с кодом:

[vba]
Код
Sub parse_data()
'Update by Extendoffice 2018/3/2
    Dim xRCount As Long
    Dim xSht As Worksheet
    Dim xNSht As Worksheet
    Dim I As Long
    Dim xTRrow As Integer
    Dim xCol As New Collection
    Dim xTitle As String
    Dim xSUpdate As Boolean
    Set xSht = ActiveSheet
    On Error Resume Next
    xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
    xTitle = "A1:H1"
    xTRrow = xSht.Range(xTitle).Cells(1).Row
    For I = 2 To xRCount
        Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
    Next
    xSUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    For I = 1 To xCol.Count
        Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
        Set xNSht = Nothing
        Set xNSht = Worksheets(CStr(xCol.Item(I)))
        If xNSht Is Nothing Then
            Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
            xNSht.Name = CStr(xCol.Item(I))
        Else
            xNSht.Move , Sheets(Sheets.Count)
        End If
        xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
        xNSht.Columns.AutoFit
    Next
    xSht.AutoFilterMode = False
    xSht.Activate
    Application.ScreenUpdating = xSUpdate
End Sub
[/vba]

Листы создать получилось, шапку таблицы перенес...но данные так и не смог((

Спасибо заранее за помощь!

Автор - Templin57
Дата добавления - 30.03.2022 в 20:36
Kuzmich Дата: Среда, 30.03.2022, 21:37 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 651
Репутация: 146 ±
Замечаний: 0% ±

Excel 2003
Цитата
Необходимо создать N-ое количество листов, которое равняется уникальным наименованиям в колонке "Продукт"

А, почему тогда, в коллекцию собираете данные из первого столбца
[vba]
Код
Sub iFruit()
Dim FilteredRng As Range
Dim i As Long
Dim iLastRow As Long
Dim iFruit As String
Dim List1 As Worksheet
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
      iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
      Set List1 = ThisWorkbook.Worksheets("Свод")
      Columns("M").ClearContents
    Range("B1:B" & iLastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M1"), Unique:=True
    iLastRow = Cells(Rows.Count, "M").End(xlUp).Row
      For i = 2 To iLastRow
        iFruit = Cells(i, "M")
            If ActiveSheet.AutoFilterMode = False Then
                Range("A1:H1").AutoFilter
            Else
                If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
            End If
              Range("A1").AutoFilter Field:=2, Criteria1:=iFruit
            With List1.AutoFilter.Range
               Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = iFruit
                .Resize(.Rows.Count, 8).SpecialCells(xlCellTypeVisible).Copy Worksheets(iFruit).Range("A1")
                Worksheets(iFruit).Columns("A:H").AutoFit
                List1.Activate
                List1.ShowAllData
            End With
      Next
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
[/vba]


Сообщение отредактировал Kuzmich - Среда, 30.03.2022, 21:52
 
Ответить
Сообщение
Цитата
Необходимо создать N-ое количество листов, которое равняется уникальным наименованиям в колонке "Продукт"

А, почему тогда, в коллекцию собираете данные из первого столбца
[vba]
Код
Sub iFruit()
Dim FilteredRng As Range
Dim i As Long
Dim iLastRow As Long
Dim iFruit As String
Dim List1 As Worksheet
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
      iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
      Set List1 = ThisWorkbook.Worksheets("Свод")
      Columns("M").ClearContents
    Range("B1:B" & iLastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M1"), Unique:=True
    iLastRow = Cells(Rows.Count, "M").End(xlUp).Row
      For i = 2 To iLastRow
        iFruit = Cells(i, "M")
            If ActiveSheet.AutoFilterMode = False Then
                Range("A1:H1").AutoFilter
            Else
                If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
            End If
              Range("A1").AutoFilter Field:=2, Criteria1:=iFruit
            With List1.AutoFilter.Range
               Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = iFruit
                .Resize(.Rows.Count, 8).SpecialCells(xlCellTypeVisible).Copy Worksheets(iFruit).Range("A1")
                Worksheets(iFruit).Columns("A:H").AutoFit
                List1.Activate
                List1.ShowAllData
            End With
      Next
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
[/vba]

Автор - Kuzmich
Дата добавления - 30.03.2022 в 21:37
Templin57 Дата: Среда, 30.03.2022, 22:52 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
А, почему тогда, в коллекцию собираете данные из первого столбца


Сори за путаницу.
Правил макрос и таблицу, прежде чем написать тут и пропустил, что в макросе осталась ссылка на А1.

Спасибо за помощь! Все работает)!!!! :D
 
Ответить
Сообщение
А, почему тогда, в коллекцию собираете данные из первого столбца


Сори за путаницу.
Правил макрос и таблицу, прежде чем написать тут и пропустил, что в макросе осталась ссылка на А1.

Спасибо за помощь! Все работает)!!!! :D

Автор - Templin57
Дата добавления - 30.03.2022 в 22:52
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание листов с данными на основе общей таблицы (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!