Помогите преобразовать таблицу!!!!

[yulia]

Здравствуйте! У меня такая проблема: имеется таблица, в ней строки вида:
Код-Текст-Текст-Наименование-Кол-во
1-text-text -стол, стул, шкаф-3

надо из нее сделать вот такое:
Код-Текст-Текст-Наименование-Кол-во
1-text-text-стол-1
1-text-text -стул-1
1-text-text-шкаф-1

Подскажите как это можно сделать, пожалуйста!!!!

[Igor_123]

В общем случае руками

таблица в екселе, ворде или ещё где?
что знаеш сама из програмирования?
стол, стул, шкаф-3 - расположенны в одной ячейке или нет?

ну и т.д. и т.п.

[yulia]

таблица в экселе.
да задача в том чтобы через vba сделать, а не руками, ибо там табличка весьма внушительного размера, и не одна... была бы маленькая я бы ее уже давно вручную сделала
а сама я из программирования знаю разве что основы к сожалению(
"стол, стул, шкаф" - в одной ячейке, "3" - в следущей.

[Igor_123]

Код: Выделить всё

Option Explicit
' Здесь нужно проставить правильные значения столбцов, откуда брать данные
' и правильные значения адресов ячеек, куда разносить эти данные
Const colName = 3
Const colKolVo = 4

Sub Razbivka()
Dim i As Long
Dim v As Variant
Dim bChange As Boolean
Dim CurRow As Long
bChange = True
CurRow = 2 ' Здесь нужно поставить номер первой строки с данными
Application.ScreenUpdating = False
Do
    If cells(CurRow, colKolVo).Value > 1 Then
        v = Split(Trim(CStr(cells(CurRow, colName).Value)), ",")
        cells(CurRow, colName).EntireRow.Copy
        Rows(CStr(CurRow + 1) & ":" & CStr(CurRow + UBound(v) - LBound(v))).Insert Shift:=xlDown
        Application.CutCopyMode = False
        For i = LBound(v) To UBound(v)
            cells(CurRow, colName).Value = Trim(v(i))
            cells(CurRow, colKolVo).Value = 1
            CurRow = CurRow + 1
            bChange = False
        Next i
    End If
If bChange Then
    CurRow = CurRow + 1
End If
bChange = True
Loop While Len(Trim(CStr(cells(CurRow, 1).Value))) <> 0
Application.ScreenUpdating = True
MsgBox "Закончили!"
End Sub

Попробуй это, только если ты говориш что табличка большая, может возникнуть ситуация, когда закончатся строчки на листе
Тогда нужно будет переделывать на другую схему

[yulia]

О, спасибо огромное!!! Работает!!!!
только вот еще такой вопрос: у меня строчки идут как бы блоками с промежуточным результатом Итого, так вот как сделать так, чтобы код после этих строк дальше выполнялся? Там в первой ячейки каждой строки стоят какие либо значения, кроме этих промежуточных строк, там эти первые ячейки пустые. Может как то по этому признаку условие сделать надо?

[Igor_123]

Код: Выделить всё

Sub Razbivka()
Dim i As Long
Dim v As Variant
Dim bChange As Boolean
Dim CurRow As Long
Dim pusto As Long
pusto = 0
bChange = True
CurRow = 2 ' Здесь нужно поставить номер первой строки с данными
Application.ScreenUpdating = False
Do
    If Len(Trim(CStr(cells(CurRow, 1).Value))) <> 0 Then
        If cells(CurRow, colKolVo).Value > 1 Then
            v = Split(Trim(CStr(cells(CurRow, colName).Value)), ",")
            cells(CurRow, colName).EntireRow.Copy
            Rows(CStr(CurRow + 1) & ":" & CStr(CurRow + UBound(v) - LBound(v))).Insert Shift:=xlDown
            Application.CutCopyMode = False
            For i = LBound(v) To UBound(v)
                cells(CurRow, colName).Value = Trim(v(i))
                cells(CurRow, colKolVo).Value = 1
                CurRow = CurRow + 1
                bChange = False
            Next i
        End If
    End If
     If bChange Then
        CurRow = CurRow + 1
    End If
    bChange = True
    If Len(Trim(CStr(cells(CurRow, 1).Value))) <> 0 Then
        pusto = pusto + 1
    Else
        pusto = 0
    End If
Loop Until pusto > 5 '<-- Это число определяет на сколько пустых ячеек реагировать как на окончание данных
Application.ScreenUpdating = True
MsgBox "Закончили!"
End Sub

Вообще- то в таком случае нужно сразу давать образец, а не добавлять по чайной ложке в час!

[yulia]

сорри, сразу не подумала... Спасибо тебе огромное!!!!!