Домашняя страница 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
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 20% ±

Дорогие, уважаемые, любимые умы, наша надежда на будущее.
Прошу помочь автоматически поделить эти таблицы по критерию в столбце 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
Группа: Друзья
Ранг: Экселист
Сообщений: 8005
Репутация: 1949 ±
Замечаний: 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
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 20% ±

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


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

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

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


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

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

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

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

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

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

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

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

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

Автор - Nika4880
Дата добавления - 17.01.2023 в 09:45
Nic70y Дата: Вторник, 17.01.2023, 12:15 | Сообщение № 9
Группа: Друзья
Ранг: Экселист
Сообщений: 8005
Репутация: 1949 ±
Замечаний: 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
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 20% ±

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

Автор - Nika4880
Дата добавления - 26.01.2023 в 09:28
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоматическое деление по критериям в столбце (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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