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. Извиняюсь за название темы , в голову не пришло другого
Добрый вечер Имеется данные в таком виде
нужно переделать в такое
нашел в интернете такой макрос [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. Извиняюсь за название темы , в голову не пришло другогоbaha
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]
Как-то так[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