Автоматическое деление по критериям в столбце

Дата: Четверг, 12.01.2023, 11:01 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 40% ±

2017

Дорогие, уважаемые, любимые умы, наша надежда на будущее.
Прошу помочь автоматически поделить эти таблицы по критерию в столбце 12 по отдельным листам, получается, по препаратам, причем у препаратов разные номера

К сообщению приложен файл: 7856622.xlsx (83.9 Kb)

Сообщение отредактировал Nika4880 - Четверг, 12.01.2023, 12:10

Дата: Четверг, 12.01.2023, 12:21 | Сообщение № 2

Группа: Друзья

Ранг: Экселист

Сообщений: 9005

Репутация: 2369 ±

Замечаний: 0% ±

Excel 2010

вдруг правильно
[vba]

Код

Sub u_128()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    For Each b In Sheets(1).Range("l2:l" & a)
        c = b.Row
        d = Application.Match(b, Sheets(1).Range("l1:l" & c), 0)
        If c = d Then
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "(" & b & ")"
            Sheets(1).Columns("A:AE").Copy
            Sheets("(" & b & ")").Columns("A:AE").PasteSpecial Paste:=xlPasteFormats
            Sheets("(" & b & ")").Columns("A:AE").Clear
            Sheets(1).Range("a1:ae1").Copy Sheets("(" & b & ")").Range("a1:ae1")
        End If
        e = Sheets("(" & b & ")").Cells(Rows.Count, "a").End(xlUp).Row + 1
        Sheets(1).Range("a" & c & ":ae" & c).Copy Sheets("(" & b & ")").Range("a" & e)
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

ЮMoney 41001841029809

Дата: Четверг, 12.01.2023, 14:14 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 40% ±

2017

не работает(((

Сообщение отредактировал Nika4880 - Четверг, 12.01.2023, 14:14

Дата: Четверг, 12.01.2023, 14:16 | Сообщение № 4

Группа: Друзья

Ранг: Экселист

Сообщений: 9005

Репутация: 2369 ±

Замечаний: 0% ±

Excel 2010

странно, у меня работает

К сообщению приложен файл: 7856622.xlsm (69.7 Kb)

ЮMoney 41001841029809

msi2102

Дата: Четверг, 12.01.2023, 14:55 | Сообщение № 5

Группа: Проверенные

Ранг: Обитатель

Сообщений: 415

Репутация: 129 ±

Замечаний: 0% ±

Excel 2007

А ТУТ не та же самая тема?

Дата: Четверг, 12.01.2023, 16:41 | Сообщение № 6

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 40% ±

2017

msi2102, Да, та же самая, но принцип я не поняла((

msi2102

Дата: Четверг, 12.01.2023, 19:00 | Сообщение № 7

Группа: Проверенные

Ранг: Обитатель

Сообщений: 415

Репутация: 129 ±

Замечаний: 0% ±

Excel 2007

Цитата Nika4880, 12.01.2023 в 16:41, в сообщении № 6 (

)

но принцип я не поняла

Принцип чего Вы не поняли?

Дата: Вторник, 17.01.2023, 09:45 | Сообщение № 8

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 40% ±

2017

Как сделат ьтак, чтобы работало не только на определенной таблице)

Дата: Вторник, 17.01.2023, 12:15 | Сообщение № 9

Группа: Друзья

Ранг: Экселист

Сообщений: 9005

Репутация: 2369 ±

Замечаний: 0% ±

Excel 2010

Двойным кликом левой кнопкой мыши по критерию.
апдэйт: немного промахнулся, исправил, файл перезалил
[vba]

Код

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    u = Target.Row      'строка заголовка
    v = Target.Column   'столбец заголовка
    s = u + 1                    'верхняя строка таблицы
    w = Cells(Rows.Count, v).End(xlUp).Row              'нижняя строка таблицы
    x = Cells(u, v).End(xlToLeft).Column                'левый столбец таблицы
    h = Cells(u, v).End(xlToLeft).Value
    If h = "" Then x = Cells(u, 1).End(xlToRight).Column
    y = Cells(u, Columns.Count).End(xlToLeft).Column    'правый столбец таблицы
    'проходимся по столбцу заголовка
    For Each b In Sheets(1).Range(Cells(s, v), Cells(w, v))
        On Error Resume Next
        c = b.Row 'очередная строка
        d = Application.Match(b, Sheets(1).Range(Cells(1, v), Cells(c, v)), 0) 'ПОИСКПОЗ()
        If c = d Then 'если это 1-е вхождение, тогда
            Sheets.Add After:=Sheets(Sheets.Count)      'создаем лист
            Sheets(Sheets.Count).Name = "(" & b & ")"   'назовем его: (текст в ячейке)
            Sheets(1).Range(Cells(u, x), Cells(u, y)).Copy 'копипаст заголовка
            With Sheets("(" & b & ")").Range("a1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
            End With
        End If
        e = Sheets("(" & b & ")").Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки
        Sheets(1).Range(Cells(c, x), Cells(c, y)).Copy Sheets("(" & b & ")").Range("a" & e) 'втавляем данные
    Next
    Cancel = True
    Application.ScreenUpdating = True
End Sub

[/vba]

Двойным кликом левой кнопкой мыши по критерию.
апдэйт: немного промахнулся, исправил, файл перезалил
[vba]

Код

[/vba]Nic70y

К сообщению приложен файл: 7856623-2-.xlsm (83.8 Kb)

ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Вторник, 17.01.2023, 13:31

СообщениеДвойным кликом левой кнопкой мыши по критерию.
апдэйт: немного промахнулся, исправил, файл перезалил
[vba]

Код

[/vba]

Автор - Nic70y
Дата добавления - 17.01.2023 в 12:15

Дата: Четверг, 26.01.2023, 09:28 | Сообщение № 10

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 40% ±

2017

Спасибо огромное)

Дата: Вторник, 07.02.2023, 16:31 | Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 40% ±

2017

Nic70y, добрый день.
А для этого документа получится?) Столбец 12: Данные по заявке в системе клиента:

К сообщению приложен файл: _31.01.23.xlsx (66.9 Kb)

Дата: Вторник, 07.02.2023, 16:54 | Сообщение № 12

Группа: Друзья

Ранг: Экселист

Сообщений: 9005

Репутация: 2369 ±

Замечаний: 0% ±

Excel 2010

слишком длинное название листа (не учел) как вариант присваивать №позиции
[vba]

Код

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    u = Target.Row      'строка заголовка
    v = Target.Column   'столбец заголовка
    s = u + 1                    'верхняя строка таблицы
    w = Cells(Rows.Count, v).End(xlUp).Row              'нижняя строка таблицы
    x = Cells(u, v).End(xlToLeft).Column                'левый столбец таблицы
    h = Cells(u, v).End(xlToLeft).Value
    If h = "" Then x = Cells(u, 1).End(xlToRight).Column
    y = Cells(u, Columns.Count).End(xlToLeft).Column    'правый столбец таблицы
    'проходимся по столбцу заголовка
    For Each b In Sheets(1).Range(Cells(s, v), Cells(w, v))
        On Error Resume Next
        c = b.Row 'очередная строка
        d = Application.Match(b, Sheets(1).Range(Cells(1, v), Cells(c, v)), 0) 'ПОИСКПОЗ()
        If c = d Then 'если это 1-е вхождение, тогда
            Sheets.Add After:=Sheets(Sheets.Count)      'создаем лист
            Sheets(Sheets.Count).Name = "(" & d & ")"   'назовем его: (ПОИСКПОЗ())
            Sheets(1).Range(Cells(u, x), Cells(u, y)).Copy 'копипаст заголовка
            With Sheets("(" & d & ")").Range("a1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
            End With
        End If
        e = Sheets("(" & d & ")").Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки
        Sheets(1).Range(Cells(c, x), Cells(c, y)).Copy Sheets("(" & d & ")").Range("a" & e) 'втавляем данные
    Next
    Cancel = True
    Application.ScreenUpdating = True
End Sub

[/vba]

слишком длинное название листа (не учел) как вариант присваивать №позиции
[vba]

Код

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    u = Target.Row      'строка заголовка
    v = Target.Column   'столбец заголовка
    s = u + 1                    'верхняя строка таблицы
    w = Cells(Rows.Count, v).End(xlUp).Row              'нижняя строка таблицы
    x = Cells(u, v).End(xlToLeft).Column                'левый столбец таблицы
    h = Cells(u, v).End(xlToLeft).Value
    If h = "" Then x = Cells(u, 1).End(xlToRight).Column
    y = Cells(u, Columns.Count).End(xlToLeft).Column    'правый столбец таблицы
    'проходимся по столбцу заголовка
    For Each b In Sheets(1).Range(Cells(s, v), Cells(w, v))
        On Error Resume Next
        c = b.Row 'очередная строка
        d = Application.Match(b, Sheets(1).Range(Cells(1, v), Cells(c, v)), 0) 'ПОИСКПОЗ()
        If c = d Then 'если это 1-е вхождение, тогда
            Sheets.Add After:=Sheets(Sheets.Count)      'создаем лист
            Sheets(Sheets.Count).Name = "(" & d & ")"   'назовем его: (ПОИСКПОЗ())
            Sheets(1).Range(Cells(u, x), Cells(u, y)).Copy 'копипаст заголовка
            With Sheets("(" & d & ")").Range("a1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
            End With
        End If
        e = Sheets("(" & d & ")").Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки
        Sheets(1).Range(Cells(c, x), Cells(c, y)).Copy Sheets("(" & d & ")").Range("a" & e) 'втавляем данные
    Next
    Cancel = True
    Application.ScreenUpdating = True
End Sub

[/vba]Nic70y

ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Вторник, 07.02.2023, 16:54