Раскидать все по листам

[dedelev]

Добрый день, уважаемые программисты.
Есть книга и в ней четыре листа. На листе "приход" забивается товар, и в первой колонке листа "приход" пишется группа товара. Дак вот нужно раскидать этот товар по листам, которые названы также, как и группы товаров. Во вложении эта книга, там написан макрос, но он беребрасывает весь товар только на первый лист. Думаю понятно объяснил. Я конечно понимаю, что это наверно проще пареной репы, но к сожалению я не программист. Помогите плиз.

[OlegVE]

Здравствуйте
Побалуйтесь с этим

Sub SHD_Split2List()
Dim ASh As Worksheet, sh As Worksheet
Dim i As Byte, LR As Long, da As Boolean
Dim NList As String
  Set ASh = ActiveSheet
  LR = ASh.[A65536].End(xlUp).Row
  For i = 1 To LR
    NList = ASh.Cells(i, 1)
    If Len(NList) > 0 Then
      For Each sh In Sheets
        If sh.Name Like NList Then da = True: Exit For
      Next
      If Not da Then
        Sheets.Add , Sheets(Sheets.Count)
        ActiveSheet.Name = NList
      Else: da = False
      End If
      ASh.Rows(i).Copy _
      Sheets(NList).Rows(Sheets(NList).[A65536].End(xlUp).Row + 1)
    End If
  Next
End Sub

Взято со странички
http://forum.msexcel.ru/microsoft_ex...o-t2601.0.html
До свидания

[dedelev]

Спасибо конечно, но некоторые строки для меня не понятны. Может кто-то даст комментарии к строкам этого кода, а то не могу применить его к моему шаблону

[dedelev]

Желающих решить мою задачу нет. Тогда объявляю мотивацию в виде бонуса 50 руб. на вебмани, тому кто первый напишет макрос

[dedelev]

Ну подскажите пожалуйста, очень надо

[EducatedFool]

Пришлось убрать итоговые строки - они заметно усложнили бы макрос.

Sub test()
    Dim cell As Range, ra As Range, DEST As Range: Application.ScreenUpdating = False
    Set ra = Range([A12], Range("A" & Rows.Count).End(xlUp))
    On Error Resume Next
    For Each cell In ra.Cells
        Set DEST = Worksheets(Trim(cell)).Range("B" & Rows.Count).End(xlUp).Offset(1)
        cell.Next.Resize(, 6).Copy DEST
    Next cell
    MsgBox "Готово - строки скопированы на листы"
End Sub

Пример в файле: http://excelvba.ru/XL_Files/Sample__...__14-50-19.zip

Я уверен это простой макрос, только подскажите. 50р. на Вебмани перекину

Не утруждайте себя. Такие суммы меня не интересуют.

[19vitek]

Sub TMC_Transport()
 kol = Application.Worksheets.Count
 For k = 1 To kol - 1
  Sheets(k).Range("P1") = 12
 Next k
Worksheets("ÏÐÈÕÎÄ").Select
i = 12
While Cells(i, 1) <> ""
 gr = Cells(i, 1)
 For j = 1 To 6
  t = Worksheets(gr).Range("P1")
  Worksheets(gr).Cells(t, j) = Cells(i, j)
 Next j
 Worksheets(gr).Range("P1") = Worksheets(gr).Range("P1") + 1
 i = i + 1
Wend
End Sub

[dedelev]

Сообщение от 19vitek

Sub TMC_Transport()
 kol = Application.Worksheets.Count
 For k = 1 To kol - 1
  Sheets(k).Range("P1") = 12
 Next k
Worksheets("ÏÐÈÕÎÄ").Select
i = 12
While Cells(i, 1) <> ""
 gr = Cells(i, 1)
 For j = 1 To 6
  t = Worksheets(gr).Range("P1")
  Worksheets(gr).Cells(t, j) = Cells(i, j)
 Next j
 Worksheets(gr).Range("P1") = Worksheets(gr).Range("P1") + 1
 i = i + 1
Wend
End Sub

19vitek, Почти подходит, а можно комментарии к строкам, а то я далек от этих слов, чтобы мне применить к своему отчету.