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

Вход

Регистрация

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

 

= Мир MS Excel/Автоматическое деление по критериям в столбце - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоматическое деление по критериям в столбце (Макросы/Sub)
Автоматическое деление по критериям в столбце
Nika4880 Дата: Четверг, 12.01.2023, 11:01 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 40% ±

2017
Дорогие, уважаемые, любимые умы, наша надежда на будущее.
Прошу помочь автоматически поделить эти таблицы по критерию в столбце 12 по отдельным листам, получается, по препаратам, причем у препаратов разные номера
К сообщению приложен файл: 7856622.xlsx (83.9 Kb)


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

Автор - Nika4880
Дата добавления - 12.01.2023 в 11:01
Nic70y Дата: Четверг, 12.01.2023, 12:21 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 8712
Репутация: 2262 ±
Замечаний: 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
 
Ответить
Сообщениевдруг правильно
[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]

Автор - Nic70y
Дата добавления - 12.01.2023 в 12:21
Nika4880 Дата: Четверг, 12.01.2023, 14:14 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 40% ±

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


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

Автор - Nika4880
Дата добавления - 12.01.2023 в 14:14
Nic70y Дата: Четверг, 12.01.2023, 14:16 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 8712
Репутация: 2262 ±
Замечаний: 0% ±

Excel 2010
странно, у меня работает
К сообщению приложен файл: 7856622.xlsm (69.7 Kb)


ЮMoney 41001841029809
 
Ответить
Сообщениестранно, у меня работает

Автор - Nic70y
Дата добавления - 12.01.2023 в 14:16
msi2102 Дата: Четверг, 12.01.2023, 14:55 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
А ТУТ не та же самая тема?
 
Ответить
СообщениеА ТУТ не та же самая тема?

Автор - msi2102
Дата добавления - 12.01.2023 в 14:55
Nika4880 Дата: Четверг, 12.01.2023, 16:41 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 40% ±

2017
msi2102, Да, та же самая, но принцип я не поняла((
 
Ответить
Сообщениеmsi2102, Да, та же самая, но принцип я не поняла((

Автор - Nika4880
Дата добавления - 12.01.2023 в 16:41
msi2102 Дата: Четверг, 12.01.2023, 19:00 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
но принцип я не поняла
Принцип чего Вы не поняли?
 
Ответить
Сообщение
но принцип я не поняла
Принцип чего Вы не поняли?

Автор - msi2102
Дата добавления - 12.01.2023 в 19:00
Nika4880 Дата: Вторник, 17.01.2023, 09:45 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 40% ±

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

Автор - Nika4880
Дата добавления - 17.01.2023 в 09:45
Nic70y Дата: Вторник, 17.01.2023, 12:15 | Сообщение № 9
Группа: Друзья
Ранг: Экселист
Сообщений: 8712
Репутация: 2262 ±
Замечаний: 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]
К сообщению приложен файл: 7856623-2-.xlsm (83.8 Kb)


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Вторник, 17.01.2023, 13:31
 
Ответить
СообщениеДвойным кликом левой кнопкой мыши по критерию.
апдэйт: немного промахнулся, исправил, файл перезалил
[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]

Автор - Nic70y
Дата добавления - 17.01.2023 в 12:15
Nika4880 Дата: Четверг, 26.01.2023, 09:28 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 40% ±

2017
Спасибо огромное)
 
Ответить
СообщениеСпасибо огромное)

Автор - Nika4880
Дата добавления - 26.01.2023 в 09:28
Nika4880 Дата: Вторник, 07.02.2023, 16:31 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 40% ±

2017
Nic70y, добрый день.
А для этого документа получится?) Столбец 12: Данные по заявке в системе клиента:
К сообщению приложен файл: _31.01.23.xlsx (66.9 Kb)
 
Ответить
СообщениеNic70y, добрый день.
А для этого документа получится?) Столбец 12: Данные по заявке в системе клиента:

Автор - Nika4880
Дата добавления - 07.02.2023 в 16:31
Nic70y Дата: Вторник, 07.02.2023, 16:54 | Сообщение № 12
Группа: Друзья
Ранг: Экселист
Сообщений: 8712
Репутация: 2262 ±
Замечаний: 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]


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Вторник, 07.02.2023, 16:54
 
Ответить
Сообщениеслишком длинное название листа (не учел) как вариант присваивать №позиции
[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
Дата добавления - 07.02.2023 в 16:54
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоматическое деление по критериям в столбце (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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