Макрос для исключения повторов

@evjen · Регистрация: 20.10.2019

Студворк — интернет-сервис помощи студентам

Добрый день. С вба не связывался со времен университета, теперь нужда заставила, но когнитивные способности уже не те.
Прошу помощи с решением следующей задачи:
В таблице на листе три столбца: первая - текст (название), вторая - число (значение), третья - текст (размерность).
Названия в некоторых строках одинаковые. Нужно на второй лист вывести таблицу, в которой не будет повторов, значения для повторяющихся строк будут просуммированы, в третий столбец будет выведена соответствующая размерность.

@Narimanych · 20.10.2019, 22:35

evjen,

Прикрепите файл.

@Hugo121 · 20.10.2019, 22:54

Если это всё в Экселе - у него есть такой функционал как сводные, там VBA не нужно знать.

@evjen · 20.10.2019, 23:03 **[ТС]**

Добрый вечер.
Набросал пример та,лицы. Здесь совпадают 1 и 4 строки, 2 и 6 строки. Результат, который хотелось бы увидеть на листе 2 тоже изобразил.
На форуме нашел похожий вопрос Суммирование одинаковых значений таблицы с практически полностью устраивающим меня решением в пятом сообщении, единственное "но" - не проставляется размерность.

@evjen · 20.10.2019, 23:08 **[ТС]**

Сообщение от Hugo121

Если это всё в Экселе - у него есть такой функционал как сводные, там VBA не нужно знать.

Спасибо, почитаю про сводные

@Hugo121 · 20.10.2019, 23:27

Ну вот в файле сводная, но я с ними не работаю, думаю можно и получше сделать.

@Narimanych · 20.10.2019, 23:37

evjen,

Для вашего примера, если строк немного, попробуйте:

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub MMM()
Application.ScreenUpdating = False
Set D = CreateObject("Scripting.Dictionary")
LR1 = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  For Each Cel In Sheets(1).Range(Cells(1, 1), Cells(LR1, 1))
    S = D.Item(Cel.Value)
  Next
   Sheets(2).Range("A1").Resize(D.Count) = Application.Transpose(D.Keys)
     For i = 1 To Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
      counter = 0
      For j = 1 To LR1
        If Sheets(2).Cells(i, 1).Value = Sheets(1).Cells(j, 1).Value Then
            counter = counter + Sheets(1).Cells(j, 2).Value
            UOM = Sheets(1).Cells(j, 3).Value
        End If
      Next
      Sheets(2).Cells(i, 2).Value = counter
      Sheets(2).Cells(i, 3).Value = UOM
    Next
Application.ScreenUpdating = True
 
End Sub

@pashulka · 20.10.2019, 23:39

evjen, Один из вариантов :

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Test()
    Dim ws1 As Worksheet, ws2 As Worksheet, r As Range
    Set ws1 = Лист1: Set ws2 = Лист2: Set r = ws1.UsedRange
    ws2.Cells.Clear
    With ws2.Cells(1).Resize(r.Rows.Count, r.Columns.Count) 'ws2.Range(r.Address)
         .Value = r.Value
         .RemoveDuplicates 1, xlNo
    End With
    With ws2.UsedRange.Columns(2)
         .Formula = "=SUMIF(" & r.Columns(1).Address(, , , True) _
         & ",A1," & r.Columns(2).Address(, , , True) & ")" '=SUMIF(Лист1!A:A,A1,Лист1!B:B)
         .Value = .Value
         .Columns.AutoFit
    End With
End Sub

@evjen · 20.10.2019, 23:56 **[ТС]**

Спасибо за помощь Hugo121, Narimanych и pashulka! На тестовой таблице все варианты отрабатывают достойно, завтра проверю на реальной. В любом случае, низкий Вам поклон=)

@pashulka · 21.10.2019, 00:06

evjen, Если столбец с размерностью можно выкинуть, ~ как в сводной таблице, то можно также использовать обычную консолидацию данных (в т.ч. и программно)

@Konstantin71 · 22.10.2019, 17:49

Скрипт очень полезный.
Хотелось бы его использовать но
Narimanych при пробе мне выдает ошибку

к сожалению слаб в макросах чтобы понять как ее поправить.

Остап Бонд · 22.10.2019, 17:56

Konstantin71, удалите Option Explicit или определите DIM D и прочие переменные повыше выделения.

Новые блоги и статьи Все статьи Все блоги /
Модель микоризы: классовый агентный подход anaschu 02.01.2026 Раньше это было два гриба и бактерия. Теперь три гриба, растение. И на уровне агентов добавится между грибами или бактериями взаимодействий. До того я пробовал подход через многомерные массивы,. . .	Учёным и волонтёрам проекта «Einstein@home» удалось обнаружить четыре гамма-лучевых пульсара в джете Млечного Пути Programma_Boinc 01.01.2026 Учёным и волонтёрам проекта «Einstein@home» удалось обнаружить четыре гамма-лучевых пульсара в джете Млечного Пути Сочетание глобально распределённой вычислительной мощности и инновационных. . .	Советы по крайней бережливости. Внимание, это ОЧЕНЬ длинный пост. Programma_Boinc 28.12.2025 Советы по крайней бережливости. Внимание, это ОЧЕНЬ длинный пост. Налог на собак: https:/ / ********/ gallery/ V06K53e Финансовый отчет в Excel: https:/ / ********/ gallery/ bKBkQFf Пост отсюда. . .	Кто-нибудь знает, где можно бесплатно получить настольный компьютер или ноутбук? США. Programma_Boinc 26.12.2025 Нашел на реддите интересную статью под названием Anyone know where to get a free Desktop or Laptop? Ниже её машинный перевод. После долгих разбирательств я наконец-то вернула себе. . .	Thinkpad X220 Tablet — это лучший бюджетный ноутбук для учёбы, точка. Programma_Boinc 23.12.2025 Рецензия / Мнение/ Перевод Нашел на реддите интересную статью под названием The Thinkpad X220 Tablet is the best budget school laptop period . Ниже её машинный перевод. Thinkpad X220 Tablet —. . .
PhpStorm 2025.3: WSL Terminal всегда стартует в ~ and_y87 14.12.2025 PhpStorm 2025. 3: WSL Terminal всегда стартует в ~ (home), игнорируя директорию проекта Симптом: После обновления до PhpStorm 2025. 3 встроенный терминал WSL открывается в домашней директории. . .	Как объединить две одинаковые БД Access с разными данными VikBal 11.12.2025 Помогите пожалуйста !! Как объединить 2 одинаковые БД Access с разными данными.	Новый ноутбук volvo 07.12.2025 Всем привет. По скидке в "черную пятницу" взял себе новый ноутбук Lenovo ThinkBook 16 G7 на Амазоне: Ryzen 5 7533HS 64 Gb DDR5 1Tb NVMe 16" Full HD Display Win11 Pro	Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .	От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .

@evjen 0 / 0 / 0 Регистрация: 20.10.2019 Сообщений: 4

	Макрос для исключения повторов 20.10.2019, 21:34. Показов 1524. Ответов 11 Метки нет (Все метки) Добрый день. С вба не связывался со времен университета, теперь нужда заставила, но когнитивные способности уже не те. Прошу помощи с решением следующей задачи: В таблице на листе три столбца: первая - текст (название), вторая - число (значение), третья - текст (размерность). Названия в некоторых строках одинаковые. Нужно на второй лист вывести таблицу, в которой не будет повторов, значения для повторяющихся строк будут просуммированы, в третий столбец будет выведена соответствующая размерность. 0

@Narimanych 2751 / 1725 / 779 Регистрация: 23.03.2015 Сообщений: 5,449
	20.10.2019, 22:35
	evjen, Прикрепите файл. 0

@Hugo121 6997 / 2895 / 555 Регистрация: 19.10.2012 Сообщений: 8,803
	20.10.2019, 22:54
	Если это всё в Экселе - у него есть такой функционал как сводные, там VBA не нужно знать. 0

@evjen 0 / 0 / 0 Регистрация: 20.10.2019 Сообщений: 4
	20.10.2019, 23:56 [ТС]
	Спасибо за помощь Hugo121, Narimanych и pashulka! На тестовой таблице все варианты отрабатывают достойно, завтра проверю на реальной. В любом случае, низкий Вам поклон=) 0

@pashulka 4138 / 2242 / 940 Регистрация: 01.12.2010 Сообщений: 4,624
	21.10.2019, 00:06
	evjen, Если столбец с размерностью можно выкинуть, ~ как в сводной таблице, то можно также использовать обычную консолидацию данных (в т.ч. и программно) 0

@Konstantin71 0 / 0 / 0 Регистрация: 18.10.2018 Сообщений: 1
	22.10.2019, 17:49
	Скрипт очень полезный. Хотелось бы его использовать но Narimanych при пробе мне выдает ошибку к сожалению слаб в макросах чтобы понять как ее поправить. Миниатюры 0

Остап Бонд Заблокирован
	22.10.2019, 17:56
	Konstantin71, удалите Option Explicit или определите DIM D и прочие переменные повыше выделения. 0