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

Вход

Регистрация

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

 

= Мир MS Excel/макрос excel который объединит данные с одинак.хар-ми - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
макрос excel который объединит данные с одинак.хар-ми
AdMiN7675 Дата: Вторник, 07.02.2023, 13:24 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

помогите написать макрос excel который поможет объединить данные разных строк с одинаковым ID в одну строку
во вложении 2 таблицы - одна исходник , а вторая как должно быть
К сообщению приложен файл: __1.xlsx (6.4 Kb)


Сообщение отредактировал AdMiN7675 - Вторник, 07.02.2023, 13:26
 
Ответить
Сообщениепомогите написать макрос excel который поможет объединить данные разных строк с одинаковым ID в одну строку
во вложении 2 таблицы - одна исходник , а вторая как должно быть

Автор - AdMiN7675
Дата добавления - 07.02.2023 в 13:24
Nic70y Дата: Вторник, 07.02.2023, 14:01 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 8801
Репутация: 2295 ±
Замечаний: 0% ±

Excel 2010
AdMiN7675, в реале данные так и идут по-порядку, как у вас в файле?
если да, то как-то так:
[vba]
Код
Sub u_11()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    For b = a To 1 Step -1
        c = Range("a" & b).Value
        If c <> "" And c = Range("a" & b + 1) Then
            Range("c" & b) = Range("c" & b) & Chr(10) & Range("c" & b + 1)
            Range("d" & b) = Range("d" & b) & Chr(10) & Range("d" & b + 1)
            Range("e" & b) = Range("e" & b) & Chr(10) & Range("e" & b + 1)
            Range("c" & b & ":e" & b).WrapText = False
        End If
    Next
    Range("a1:e" & a).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: _1.xlsm (21.2 Kb)


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Вторник, 07.02.2023, 14:56
 
Ответить
СообщениеAdMiN7675, в реале данные так и идут по-порядку, как у вас в файле?
если да, то как-то так:
[vba]
Код
Sub u_11()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    For b = a To 1 Step -1
        c = Range("a" & b).Value
        If c <> "" And c = Range("a" & b + 1) Then
            Range("c" & b) = Range("c" & b) & Chr(10) & Range("c" & b + 1)
            Range("d" & b) = Range("d" & b) & Chr(10) & Range("d" & b + 1)
            Range("e" & b) = Range("e" & b) & Chr(10) & Range("e" & b + 1)
            Range("c" & b & ":e" & b).WrapText = False
        End If
    Next
    Range("a1:e" & a).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 07.02.2023 в 14:01
AdMiN7675 Дата: Вторник, 07.02.2023, 15:39 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Nic70y, данные не всегда идут по порядку, но отсортировать руками это не проблема. Спасибо большое, сейчас попробую реализовать то что вы написали.
 
Ответить
СообщениеNic70y, данные не всегда идут по порядку, но отсортировать руками это не проблема. Спасибо большое, сейчас попробую реализовать то что вы написали.

Автор - AdMiN7675
Дата добавления - 07.02.2023 в 15:39
AdMiN7675 Дата: Вторник, 07.02.2023, 17:04 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Nic70y, пробую чтобы данные с одинаковыми ID выводились в 1 ячейку, но почему то в последней строчке вывод неверный

[vba]
Код

If c <> "" And c = Range("a" & b + 1) Then
Range("c" & b) = Range("c" & b) & " " & Range("d" & b)& " " & Range("e" & b ) & Chr(10) & Range("c" & b+1) & " " & Range("d" & b+1) & "" & Range("e" & b+1 )
Range("c" & b & ":e" & b).WrapText = False
End If

[/vba]


Сообщение отредактировал AdMiN7675 - Вторник, 07.02.2023, 17:17
 
Ответить
СообщениеNic70y, пробую чтобы данные с одинаковыми ID выводились в 1 ячейку, но почему то в последней строчке вывод неверный

[vba]
Код

If c <> "" And c = Range("a" & b + 1) Then
Range("c" & b) = Range("c" & b) & " " & Range("d" & b)& " " & Range("e" & b ) & Chr(10) & Range("c" & b+1) & " " & Range("d" & b+1) & "" & Range("e" & b+1 )
Range("c" & b & ":e" & b).WrapText = False
End If

[/vba]

Автор - AdMiN7675
Дата добавления - 07.02.2023 в 17:04
Nic70y Дата: Вторник, 07.02.2023, 17:14 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 8801
Репутация: 2295 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Sub u_11()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    For b = a To 1 Step -1
        c = Range("a" & b).Value
        Range("c" & b) = Range("c" & b) & " " & Range("d" & b) & " " & Range("e" & b)
        Range("d" & b & ":e" & b).Clear
        If c <> "" And c = Range("a" & b + 1) Then
            Range("c" & b) = Range("c" & b) & Chr(10) & Range("c" & b + 1)
            Range("c" & b).WrapText = False
        End If
    Next
    Range("a1:c" & a).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub
[/vba]


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Вторник, 07.02.2023, 17:20
 
Ответить
Сообщение[vba]
Код
Sub u_11()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    For b = a To 1 Step -1
        c = Range("a" & b).Value
        Range("c" & b) = Range("c" & b) & " " & Range("d" & b) & " " & Range("e" & b)
        Range("d" & b & ":e" & b).Clear
        If c <> "" And c = Range("a" & b + 1) Then
            Range("c" & b) = Range("c" & b) & Chr(10) & Range("c" & b + 1)
            Range("c" & b).WrapText = False
        End If
    Next
    Range("a1:c" & a).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 07.02.2023 в 17:14
AdMiN7675 Дата: Вторник, 07.02.2023, 18:31 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Nic70y, спасибо все отлично! немного доработала и получилось то что нужно!
 
Ответить
СообщениеNic70y, спасибо все отлично! немного доработала и получилось то что нужно!

Автор - AdMiN7675
Дата добавления - 07.02.2023 в 18:31
  • Страница 1 из 1
  • 1
Поиск:

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