Приобразование горизонтальных данных в вертикальное

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Приобразование горизонтальных данных в вертикальное (Макросы/Sub)

baha

Дата: Понедельник, 26.10.2015, 18:44 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Добрый вечер
Имеется данные в таком виде

нужно переделать в такое

нашел в интернете такой макрос
[vba]

Код

Sub tt()
    Dim a(), i&, ii&, x&
    a = [a1].CurrentRegion.Value
    ReDim b(1 To UBound(a) * 3 - 2, 1 To 2)
    b(1, 1) = "ID": b(1, 2) = "NAME"
    x = 1
    For i = 2 To UBound(a, 1)
        If a(i, 2) & a(i, 3) & a(i, 4) <> "000" Then
            For ii = 2 To UBound(a, 2)
                x = x + 1
                b(x, 1) = a(i, 1)
                b(x, 2) = a(i, ii)
            Next
        End If
    Next
    Workbooks.Add(1).Sheets(1).[a1].Resize(x, 2) = b
End Sub

[/vba]
Макрос рабочий, только немного не подходит
Помогите пожалуйста допилить его под мой нужды
мне нужно что бы:
1. если имеется "0" в ячейке что бы удалялось ID,0,способ доставки
2. При преобразовании получилось 3 столбика ID,цена,способ доставки

PS. Извиняюсь за название темы , в голову не пришло другого

К сообщению приложен файл: 2003.xls (19.5 Kb) · 2007.xlsx (9.1 Kb)

Ответить

RAN

Дата: Понедельник, 26.10.2015, 19:03 | Сообщение № 2

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

http://www.excelworld.ru/forum/3-15667-1

Быть или не быть, вот в чем загвоздка!

Ответить

МВТ

Дата: Понедельник, 26.10.2015, 19:05 | Сообщение № 3

Группа: Проверенные

Ранг: Обитатель

Сообщений: 476

Репутация: 137 ±

Замечаний: 0% ±

Excel 2007

Как-то так[vba]

Код

Sub tt()
Dim I As Long, J As Long
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = Sheets("Ëèñò3")
With ws
    .Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Clear
    For I = 2 To Cells(Rows.Count, 1).End(xlUp).Row
     For J = 1 To 3
      .Cells((I - 1) * 3 + J - 1, 1) = Cells(I, 1)
      .Cells((I - 1) * 3 + J - 1, 3) = Cells(1, J + 1)
      .Cells((I - 1) * 3 + J - 1, 2) = Cells(I, J + 1)
     Next
    Next
    .Range("A1:B1").Value = Split("ID Name")
End With
Application.ScreenUpdating = True
End Sub

[/vba]