Помогите пожалуйста написать макрос для объединения строк в exel. Третий день уже сижу над этим вопросом и никак не могу найти решение,взорвал весь гугл,яндекс и всё т.п. Есть прайс лист ( вложен в сообщении) , надо сделать так,чтобы данные из столбцов B и С перенеслись в столбец А и были прописаны через разделитель "/",т.е. вот кусочек из прайса (изначальный вид)
Gender Brand Type
man 7 FOR ALL MANKIND Pants man 7 FOR ALL MANKIND Pants woman 7 FOR ALL MANKIND Jeans woman 7 FOR ALL MANKIND Jeans woman 7 FOR ALL MANKIND Jeans woman 7 FOR ALL MANKIND Jeans
а надо
Gender/Brand/Type
man/7 FOR ALL MANKIND/Pants man/7 FOR ALL MANKIND/Pants woman/7 FOR ALL MANKIND/Jeans woman/7 FOR ALL MANKIND/Jeans woman/7 FOR ALL MANKIND/Jeans woman/7 FOR ALL MANKIND/Jeans
Помогите пожалуйста,а то я не могу сдвинуться с места,буду очень признателен....
Помогите пожалуйста написать макрос для объединения строк в exel. Третий день уже сижу над этим вопросом и никак не могу найти решение,взорвал весь гугл,яндекс и всё т.п. Есть прайс лист ( вложен в сообщении) , надо сделать так,чтобы данные из столбцов B и С перенеслись в столбец А и были прописаны через разделитель "/",т.е. вот кусочек из прайса (изначальный вид)
Gender Brand Type
man 7 FOR ALL MANKIND Pants man 7 FOR ALL MANKIND Pants woman 7 FOR ALL MANKIND Jeans woman 7 FOR ALL MANKIND Jeans woman 7 FOR ALL MANKIND Jeans woman 7 FOR ALL MANKIND Jeans
а надо
Gender/Brand/Type
man/7 FOR ALL MANKIND/Pants man/7 FOR ALL MANKIND/Pants woman/7 FOR ALL MANKIND/Jeans woman/7 FOR ALL MANKIND/Jeans woman/7 FOR ALL MANKIND/Jeans woman/7 FOR ALL MANKIND/Jeans
Помогите пожалуйста,а то я не могу сдвинуться с места,буду очень признателен....libero23
Sub www() Dim x(), rez(), a& x = Range([a1], Cells(Rows.Count, 1).End(xlUp).Offset(0, 14)).Value ReDim rez(1 To UBound(x), 1 To 12) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For a = 1 To UBound(x) rez(a, 1) = x(a, 1) & "/" & x(a, 2) & "/" & x(a, 3) rez(a, 2) = x(a, 4): rez(a, 3) = x(a, 5): rez(a, 4) = x(a, 6): rez(a, 5) = x(a, 7) rez(a, 6) = x(a, 8): rez(a, 7) = x(a, 9): rez(a, 8) = x(a, 10): rez(a, 9) = x(a, 11) rez(a, 10) = x(a, 12): rez(a, 11) = x(a, 13): rez(a, 12) = x(a, 14) Next End With Cells.Clear Range("A1").Resize(a - 1, 12) = rez() Cells.RowHeight = 15 End Sub
[/vba]
[vba]
Code
Sub www() Dim x(), rez(), a&, i& x = Range([a1], Cells(Rows.Count, 1).End(xlUp).Offset(0, 14)).Value ReDim rez(1 To UBound(x), 1 To 12) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For a = 1 To UBound(x) rez(a, 1) = x(a, 1) & "/" & x(a, 2) & "/" & x(a, 3) For i = 2 To 12 rez(a, i) = x(a, i + 2) Next Next End With Cells.Clear Range("A1").Resize(a - 1, 12) = rez() Cells.RowHeight = 15 End Sub
[/vba]
не успел формулой макрос
[vba]
Code
Sub www() Dim x(), rez(), a& x = Range([a1], Cells(Rows.Count, 1).End(xlUp).Offset(0, 14)).Value ReDim rez(1 To UBound(x), 1 To 12) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For a = 1 To UBound(x) rez(a, 1) = x(a, 1) & "/" & x(a, 2) & "/" & x(a, 3) rez(a, 2) = x(a, 4): rez(a, 3) = x(a, 5): rez(a, 4) = x(a, 6): rez(a, 5) = x(a, 7) rez(a, 6) = x(a, 8): rez(a, 7) = x(a, 9): rez(a, 8) = x(a, 10): rez(a, 9) = x(a, 11) rez(a, 10) = x(a, 12): rez(a, 11) = x(a, 13): rez(a, 12) = x(a, 14) Next End With Cells.Clear Range("A1").Resize(a - 1, 12) = rez() Cells.RowHeight = 15 End Sub
[/vba]
[vba]
Code
Sub www() Dim x(), rez(), a&, i& x = Range([a1], Cells(Rows.Count, 1).End(xlUp).Offset(0, 14)).Value ReDim rez(1 To UBound(x), 1 To 12) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For a = 1 To UBound(x) rez(a, 1) = x(a, 1) & "/" & x(a, 2) & "/" & x(a, 3) For i = 2 To 12 rez(a, i) = x(a, i + 2) Next Next End With Cells.Clear Range("A1").Resize(a - 1, 12) = rez() Cells.RowHeight = 15 End Sub
Файлик положить в папку с этим csv и запустить даблкликом. Результат будет рядом, под именем ExportProducts2.csv Если что - код правится в блокноте.
Файлик положить в папку с этим csv и запустить даблкликом. Результат будет рядом, под именем ExportProducts2.csv Если что - код правится в блокноте.Hugo
Sub Macros() Dim i As Integer For i = 2 To Range("A1").End(xlDown).Row Range("A" & i) = Join(Array(Range("A" & i), Range("B" & i), Range("C" & i)), "/") Next i Columns("B:C").Delete Shift:=xlToLeft End Sub
[/vba]
Еще вариант макроса [vba]
Code
Sub Macros() Dim i As Integer For i = 2 To Range("A1").End(xlDown).Row Range("A" & i) = Join(Array(Range("A" & i), Range("B" & i), Range("C" & i)), "/") Next i Columns("B:C").Delete Shift:=xlToLeft End Sub
Sub Macros() Dim i As Integer For i = 2 To Range("A1").End(xlDown).Row Range("A" & i) = Join(Array(Range("A" & i), Range("B" & i), Range("C" & i)), "/") Next i Columns("B:C").Delete Shift:=xlToLeft End Sub
Этот тоже подходит Ого,как много решений,а я 3 дня не мог справиться Надо было сразу на форумы обращаться,но я думал.что всё гугл поможет ))
Quote (AlexM)
Sub Macros() Dim i As Integer For i = 2 To Range("A1").End(xlDown).Row Range("A" & i) = Join(Array(Range("A" & i), Range("B" & i), Range("C" & i)), "/") Next i Columns("B:C").Delete Shift:=xlToLeft End Sub
Этот тоже подходит Ого,как много решений,а я 3 дня не мог справиться Надо было сразу на форумы обращаться,но я думал.что всё гугл поможет ))libero23
AlexM, для счётчика строк не используйте Integer - это тут строк мало, а у других и по "сто тыщ" бывает... Да и вообще Integer потерял смысл в VBA: http://msdn.microsoft.com/en-us/library/aa164754(office.10).aspx Ну и в Вашем коде было бы в 40 раз быстрее делать через массив, примерно как у ABC - взяли 3 столбца в массив, переложили, выгрузили назад.
AlexM, для счётчика строк не используйте Integer - это тут строк мало, а у других и по "сто тыщ" бывает... Да и вообще Integer потерял смысл в VBA: http://msdn.microsoft.com/en-us/library/aa164754(office.10).aspx Ну и в Вашем коде было бы в 40 раз быстрее делать через массив, примерно как у ABC - взяли 3 столбца в массив, переложили, выгрузили назад.Hugo
Файлик положить в папку с этим csv и запустить даблкликом. Результат будет рядом, под именем ExportProducts2.csv Если что - код правится в блокноте. К сообщению приложен файл: parser_todo.vbs(1Kb)
Я только-что разобрался,как запустить....супер вариант вообще спасибо Вам всем за помощь )))
Quote (Hugo)
Файлик положить в папку с этим csv и запустить даблкликом. Результат будет рядом, под именем ExportProducts2.csv Если что - код правится в блокноте. К сообщению приложен файл: parser_todo.vbs(1Kb)
Я только-что разобрался,как запустить....супер вариант вообще спасибо Вам всем за помощь )))libero23
Public Sub www() Dim r As Range: Set r = Range("a2", [a65536].End(xlUp)) r.Value = Evaluate(r.Address & "&""/""&" & _ r.Offset(, 1).Address & "&""/""&" & r.Offset(, 2).Address) [b:c].Delete End Sub
[/vba]
Проще: [vba]
Code
Public Sub www() Dim r As Range: Set r = Range("a2", [a65536].End(xlUp)) r.Value = Evaluate(r.Address & "&""/""&" & _ r.Offset(, 1).Address & "&""/""&" & r.Offset(, 2).Address) [b:c].Delete End Sub
Мой Если серьёзно - все на массивах отработают так что и не заметите. Мой работает иначе - он работает напрямую с текстом. На 10000 тоже будет быстро, но его можно ещё ускорить - не писать на выход построчно, а тоже собрать всё в массив и его выгрузить в файл сразу весь. Это если строк будет значительно больше.
Мой Если серьёзно - все на массивах отработают так что и не заметите. Мой работает иначе - он работает напрямую с текстом. На 10000 тоже будет быстро, но его можно ещё ускорить - не писать на выход построчно, а тоже собрать всё в массив и его выгрузить в файл сразу весь. Это если строк будет значительно больше.Hugo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
