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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос данных из ячейки по строкам - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных из ячейки по строкам (Макросы/Sub)
Перенос данных из ячейки по строкам
Kravets Дата: Понедельник, 08.12.2014, 10:48 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте, очень нужна помощь по данному вопросу. В ячеках есть данные с разделителем "&", надо чтоб значение после разделителя переносилось на новую строку. Есть макрос который это делает, но он делает это по одному столбцу, нужно чтоб он обробатывал сразу несколько столбцов.
Вот пример макроса:
[vba]
Код
Sub SplitcellD()
Dim arrS() As String
Dim i&
For i = Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
     arrS = Split(Cells(i, "D").Value, "&" & vbLf)
     If UBound(arrS) > 0 Then
         Range(Rows(i + 1), Rows(i + UBound(arrS))).Insert
         Cells(i, "D").Resize(UBound(arrS) + 1).Value = Application.Transpose(arrS)
     End If
Next i
End Sub
[/vba]
К сообщению приложен файл: 4992735.rar (6.7 Kb)
 
Ответить
СообщениеЗдравствуйте, очень нужна помощь по данному вопросу. В ячеках есть данные с разделителем "&", надо чтоб значение после разделителя переносилось на новую строку. Есть макрос который это делает, но он делает это по одному столбцу, нужно чтоб он обробатывал сразу несколько столбцов.
Вот пример макроса:
[vba]
Код
Sub SplitcellD()
Dim arrS() As String
Dim i&
For i = Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
     arrS = Split(Cells(i, "D").Value, "&" & vbLf)
     If UBound(arrS) > 0 Then
         Range(Rows(i + 1), Rows(i + UBound(arrS))).Insert
         Cells(i, "D").Resize(UBound(arrS) + 1).Value = Application.Transpose(arrS)
     End If
Next i
End Sub
[/vba]
Автор - Kravets
Дата добавления - 08.12.2014 в 10:48
Cheshir0067 Дата: Понедельник, 08.12.2014, 11:35 | Сообщение № 2
Группа: Проверенные
Ранг: Новичок
Сообщений: 35
Репутация: 8 ±
Замечаний: 0% ±

Excel 2010
Буква "D" означает столбец, добавьте количество циклов равнозначное количеству столбцов , затем замените названия столбцов в новых циклах.

irelandzp@gmail.com
 
Ответить
СообщениеБуква "D" означает столбец, добавьте количество циклов равнозначное количеству столбцов , затем замените названия столбцов в новых циклах.
Автор - Cheshir0067
Дата добавления - 08.12.2014 в 11:35
Kravets Дата: Понедельник, 08.12.2014, 11:53 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
В таком случаае, каждый столбец опускается ниже предыдущего лесенкой получается. Хотелось бы чтоб все значения оставались друг на против друга как это сейчас в файле, только с разбивкой по строкам.
 
Ответить
СообщениеВ таком случаае, каждый столбец опускается ниже предыдущего лесенкой получается. Хотелось бы чтоб все значения оставались друг на против друга как это сейчас в файле, только с разбивкой по строкам.
Автор - Kravets
Дата добавления - 08.12.2014 в 11:53
Kravets Дата: Понедельник, 08.12.2014, 11:59 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Может как то можно указать в этом макросе, нужные столбцы?
 
Ответить
СообщениеМожет как то можно указать в этом макросе, нужные столбцы?
Автор - Kravets
Дата добавления - 08.12.2014 в 11:59
Kravets Дата: Понедельник, 08.12.2014, 12:08 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Вот так получается если добовлять количество циклов равнозначное количеству столбцов
К сообщению приложен файл: 9443987.xlsx (13.4 Kb)
 
Ответить
СообщениеВот так получается если добовлять количество циклов равнозначное количеству столбцов
Автор - Kravets
Дата добавления - 08.12.2014 в 12:08
Gustav Дата: Понедельник, 08.12.2014, 13:02 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2748
Репутация: 1137 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
У меня нечто такое получилось:
[vba]
Код
Sub Splitcells()
     Dim arrS$(), i&, rcur&, rmax&
     For i = 2 To 6 'цикл по колонкам
         arrS = Split(Cells(1, i).Value, "&" & vbLf)
         rcur = UBound(arrS) + 1
         If rcur > rmax Then Rows(2 + rmax).Resize(rcur - rmax).Insert
         Cells(2, i).Resize(rcur).Value = Application.Transpose(arrS)
         rmax = WorksheetFunction.Max(rcur, rmax)
     Next i
End Sub
[/vba]

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 08.12.2014, 13:54
 
Ответить
СообщениеУ меня нечто такое получилось:
[vba]
Код
Sub Splitcells()
     Dim arrS$(), i&, rcur&, rmax&
     For i = 2 To 6 'цикл по колонкам
         arrS = Split(Cells(1, i).Value, "&" & vbLf)
         rcur = UBound(arrS) + 1
         If rcur > rmax Then Rows(2 + rmax).Resize(rcur - rmax).Insert
         Cells(2, i).Resize(rcur).Value = Application.Transpose(arrS)
         rmax = WorksheetFunction.Max(rcur, rmax)
     Next i
End Sub
[/vba]
Автор - Gustav
Дата добавления - 08.12.2014 в 13:02
Kravets Дата: Понедельник, 08.12.2014, 14:05 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Отлично работает, только вот если на листе больше чем одна строка с данными, то обрабатывается только одна.
 
Ответить
СообщениеОтлично работает, только вот если на листе больше чем одна строка с данными, то обрабатывается только одна.
Автор - Kravets
Дата добавления - 08.12.2014 в 14:05
Gustav Дата: Понедельник, 08.12.2014, 14:41 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2748
Репутация: 1137 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Для нескольких исходных строк:
[vba]
Код
Sub Splitcells3()
      Dim arrS$(), i&, j&, rcur&, rmax&, r&
      r = 1
      For j = 1 To 3 'цикл по исходным строкам
          rmax = 0
          For i = 2 To 6 'цикл по колонкам
              arrS = Split(Cells(r, i).Value, "&" & vbLf)
              rcur = UBound(arrS) + 1
              If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert
              Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS)
              rmax = WorksheetFunction.Max(rcur, rmax)
          Next i
          r = r + 1 + rmax
      Next j
End Sub
[/vba]
А если надо чтобы новые строки полностью заменяли исходные, то так:
[vba]
Код
Sub Splitcells4()
     Dim arrS$(), i&, j&, rcur&, rmax&, r&
     r = 1
     For j = 1 To 3 'цикл по исходным строкам
         rmax = 0
         For i = 2 To 6 'цикл по колонкам
             arrS = Split(Cells(r, i).Value, "&" & vbLf)
             rcur = UBound(arrS) + 1
             If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert
             Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS)
             rmax = WorksheetFunction.Max(rcur, rmax)
         Next i
         Rows(r).Delete 'ЭТО ДОБАВИЛОСЬ
         r = r + rmax   'А ЭТО ИЗМЕНИЛОСЬ
     Next j
End Sub
[/vba]

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 08.12.2014, 14:59
 
Ответить
СообщениеДля нескольких исходных строк:
[vba]
Код
Sub Splitcells3()
      Dim arrS$(), i&, j&, rcur&, rmax&, r&
      r = 1
      For j = 1 To 3 'цикл по исходным строкам
          rmax = 0
          For i = 2 To 6 'цикл по колонкам
              arrS = Split(Cells(r, i).Value, "&" & vbLf)
              rcur = UBound(arrS) + 1
              If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert
              Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS)
              rmax = WorksheetFunction.Max(rcur, rmax)
          Next i
          r = r + 1 + rmax
      Next j
End Sub
[/vba]
А если надо чтобы новые строки полностью заменяли исходные, то так:
[vba]
Код
Sub Splitcells4()
     Dim arrS$(), i&, j&, rcur&, rmax&, r&
     r = 1
     For j = 1 To 3 'цикл по исходным строкам
         rmax = 0
         For i = 2 To 6 'цикл по колонкам
             arrS = Split(Cells(r, i).Value, "&" & vbLf)
             rcur = UBound(arrS) + 1
             If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert
             Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS)
             rmax = WorksheetFunction.Max(rcur, rmax)
         Next i
         Rows(r).Delete 'ЭТО ДОБАВИЛОСЬ
         r = r + rmax   'А ЭТО ИЗМЕНИЛОСЬ
     Next j
End Sub
[/vba]
Автор - Gustav
Дата добавления - 08.12.2014 в 14:41
Kravets Дата: Понедельник, 08.12.2014, 15:02 | Сообщение № 9
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Цитата Gustav, 08.12.2014 в 14:41, в сообщении № 8
Cells(r + 1

Спасибо большое за помощь, еще один вопрос как сделать чтоб удалялись неотформатированые данные. А то сейчас остаются значения в одной строке и ниже т же значения разбиты по строкам
 
Ответить
Сообщение
Цитата Gustav, 08.12.2014 в 14:41, в сообщении № 8
Cells(r + 1

Спасибо большое за помощь, еще один вопрос как сделать чтоб удалялись неотформатированые данные. А то сейчас остаются значения в одной строке и ниже т же значения разбиты по строкам
Автор - Kravets
Дата добавления - 08.12.2014 в 15:02
Kravets Дата: Понедельник, 08.12.2014, 15:03 | Сообщение № 10
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Цитата Gustav, 08.12.2014 в 14:41, в сообщении № 8
Sub Splitcells4()
Dim arrS$(), i&, j&, rcur&, rmax&, r&
r = 1
For j = 1 To 3 'цикл по исходным строкам
rmax = 0
For i = 2 To 6 'цикл по колонкам
arrS = Split(Cells(r, i).Value, "&" & vbLf)
rcur = UBound(arrS) + 1
If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert
Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS)
rmax = WorksheetFunction.Max(rcur, rmax)
Next i
Rows®.Delete 'ЭТО ДОБАВИЛОСЬ
r = r + rmax 'А ЭТО ИЗМЕНИЛОСЬ
Next j
End Sub


Спасибо! Все работает именно так как нужно было!


Сообщение отредактировал Kravets - Понедельник, 08.12.2014, 15:04
 
Ответить
Сообщение
Цитата Gustav, 08.12.2014 в 14:41, в сообщении № 8
Sub Splitcells4()
Dim arrS$(), i&, j&, rcur&, rmax&, r&
r = 1
For j = 1 To 3 'цикл по исходным строкам
rmax = 0
For i = 2 To 6 'цикл по колонкам
arrS = Split(Cells(r, i).Value, "&" & vbLf)
rcur = UBound(arrS) + 1
If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert
Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS)
rmax = WorksheetFunction.Max(rcur, rmax)
Next i
Rows®.Delete 'ЭТО ДОБАВИЛОСЬ
r = r + rmax 'А ЭТО ИЗМЕНИЛОСЬ
Next j
End Sub


Спасибо! Все работает именно так как нужно было!
Автор - Kravets
Дата добавления - 08.12.2014 в 15:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных из ячейки по строкам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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