Заполнение данных в макете этикетки из таблицы

[Kapany3uk]

Добрый день всем, прошу прощения если данная тема уже есть, поиск мне не дал результата
Есть Excel 2007, помогите нужен макросом.
Нужно чтобы заполнялся шаблон этикетки из таблицы с данными (пример во вложении) .
Данные в этикетки должны быть согласно артикулу, далее копируется макет этикетки и в нее вставляются данные по следующему артикулу и так далее пока есть заполненные столбцы с артикулами.
Все этикетки должны быть на одном листе, что бы в дальнейшем их можно было сохранить в PDF и отправить на печать.

Заранее благодарен.

[Kapany3uk]

Добрый день, пока смог разобраться только с заполнением и копированием, подскажите как сделать цикл до последней заполненной Ячейки и как что бы в каждом новом цикле данные брались из следующей ячейки?
Что то я затормозился на этом(
код ниже
Sub Ìàêðîñ3()
' Ìàêðîñ3 Ìàêðîñ
' Ýòèêåòêà
Do While (x < 5)
x = x + 1

Range("B1") = Worksheets("äàííûå").Cells(2, 1)
Range("B2") = Worksheets("äàííûå").Cells(2, 2)
Range("B3") = Worksheets("äàííûå").Cells(2, 3)
Range("B4") = Worksheets("äàííûå").Cells(2, 4)
Range("B5") = Worksheets("äàííûå").Cells(2, 5)
Range("B6") = Worksheets("äàííûå").Cells(2, 6)
Range("B7") = Worksheets("äàííûå").Cells(2, 7)
Range("B8") = Worksheets("äàííûå").Cells(2, 8)
Range("B9") = Worksheets("äàííûå").Cells(2, 9)
Range("B10") = Worksheets("äàííûå").Cells(2, 10)
Range("B11") = Worksheets("äàííûå").Cells(2, 11)
Range("B12") = Worksheets("äàííûå").Cells(2, 12)
Range("B13") = Worksheets("äàííûå").Cells(2, 13)
Range("B14") = Worksheets("äàííûå").Cells(2, 14)
Rows("1:20").Select
Range("A20").Activate
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A21:B39").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-24
Range("A1").Select
ActiveSheet.Paste
Range("B1:B14").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("B1").Select
Loop

End Sub

[Aleksandr H.]

Оформите код "читабельнее"

[Kapany3uk]

Сори, ерунда какая-то и в правду отразилась.
Вот читабельная версия:

Sub 
Do While (x < 5)
x = x + 1

Range("B1") = Worksheets("данные").Cells(2, 1)
Range("B2") = Worksheets("данные").Cells(2, 2)
Range("B3") = Worksheets("данные").Cells(2, 3)
Range("B4") = Worksheets("данные").Cells(2, 4)
Range("B5") = Worksheets("данные").Cells(2, 5)
Range("B6") = Worksheets("данные").Cells(2, 6)
Range("B7") = Worksheets("данные”).Cells(2, 7)
Range("B8") = Worksheets("данные").Cells(2, 8)
Range("B9") = Worksheets("данные").Cells(2, 9)
Range("B10") = Worksheets("данные").Cells(2, 10)
Range("B11") = Worksheets("данные").Cells(2, 11)
Range("B12") = Worksheets("данные").Cells(2, 12)
Range("B13") = Worksheets("данные").Cells(2, 13)
Range("B14") = Worksheets("данные").Cells(2, 14)
Rows("1:20").Select
Range("A20").Activate
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A21:B39").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-24
Range("A1").Select
ActiveSheet.Paste
Range("B1:B14").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("B1").Select
Loop

End

_____
Код программы нужно выделять (форматировать) тегами [CODE] [/CODE] (читать FAQ)
Модератор

[Aleksandr H.]

Sub SomeWOrk()
    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim s3 As Worksheet
    Dim x As Integer
    Dim y As Integer
    Dim iRow As Integer
    x = 1
    Set s1 = Sheets(1)
    Set s2 = Sheets(2)
    Set s3 = Sheets(3)
    x = s1.Cells(s1.Rows.Count, "A").End(xlUp).Row
    iRow = 2
    y = 1
    Do While (iRow <= x)
        s2.Range("B1:B14").Value = Application.Transpose(s1.Range("A" & iRow & ":N" & iRow).Value)
        s2.Range("A1:B20").Copy
        s3.Cells(y, "A").PasteSpecial Paste:=xlPasteColumnWidths
        s3.Cells(y, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        s3.Cells(y, "A").PasteSpecial Paste:=xlPasteFormats
        y = y + 20
        Application.CutCopyMode = False
        iRow = iRow + 1
    Loop

End Sub

[Kapany3uk]

_____
Код программы нужно выделять (форматировать) тегами [CODE] [/CODE] (читать FAQ)
Модератор

Прошу понять и простить, учту на будущее.

Aleksandr H.

Спасибо огромное.
Я немного поправил и доработал Ваш код, вот что у меня получилось

Sub SomeWOrk()
 Dim cell As Range, ra As Range, n As Long: Application.ScreenUpdating = False
    Set ra = Range([d5], Range("d" & Rows.Count).End(xlUp))
    Dim Этикетки As Worksheet: Set Этикетки = Worksheets.Add(, Worksheets(Worksheets.Count))
    Этикетки.Name = "Этикетки " & Format(Now, "DD-MM-YYYY HH-NN-SS")
    With Этикетки.PageSetup
        .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1000
    End With
    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim s3 As Worksheet
    Dim x As Integer
    Dim y As Integer
    Dim iRow As Integer
    x = 1
    Set s1 = Sheets(1)
    Set s2 = Sheets(2)
    Set s3 = Sheets(3)
    x = s1.Cells(s1.Rows.Count, "A").End(xlUp).Row
    iRow = 2
    y = 1
    Do While (iRow <= x)
        s2.Range("B1:B14").Value = Application.Transpose(s1.Range("A" & iRow & ":N" & iRow).Value)
        s2.Range("A1:B20").Copy
        s3.Cells(y, "A").PasteSpecial Paste:=xlPasteColumnWidths
        s3.Cells(y, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        s3.Cells(y, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
        y = y + 20
        Application.CutCopyMode = False
        iRow = iRow + 1
    Loop

End Sub

Теперь не обязательно что бы был третий лист, он создается автоматом

[Aleksandr H.]

Зачем?

Сообщение от Kapany3uk

Set ra = Range([d5], Range("d" & Rows.Count).End(xlUp))

Сообщение от Kapany3uk

ActiveSheet.Paste

Вставку рисунка обработали?

[Kapany3uk]

Согласен, бесполезная команда. Брал из другого массива данных и не проверил.
Это моя первая встреча с макроваси и VBA. Еще очень мало что понимаю в этом. До этого максимум пользовался ВПР ))

Сообщение от Aleksandr H.

Зачем?
Цитата:
Сообщение от Kapany3uk
Set ra = Range([d5], Range("d" & Rows.Count).End(xlUp))

Да, теперь копируется вместе с рисунком.

Сообщение от Aleksandr H.

Цитата:
Сообщение от Kapany3uk
ActiveSheet.Paste
Вставку рисунка обработали?

[Kapany3uk]

Всем доброго дня, немного поправил макрос под себя. Теперь появилась следующая задача Нужно что бы создавалось 3 этикетки по горизонтали, далее через одну строчку нижу продолжалось создание этикетки. Снова делалось 3 шт и так далее.
То есть нужно что бы макрос повторялся 3 раза, потом опускался через одну пустую строчку и продолжался опять 3 раза и так далее.
Кто сможет помочь.
Заранее благодарен.

Sub SomeWOrk()
    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim s3 As Worksheet
    Dim x As Integer
    Dim y As Integer
    Dim iRow As Integer
    x = 1
    Set s1 = Sheets(1)
    Set s2 = Sheets(2)
    Set s3 = Sheets(3)
    x = s1.Cells(s1.Rows.Count, "A").End(xlUp).Row
    iRow = 2
    y = 1
    Z = 3
    a = 22
   Do While (iRow <= x)
        s2.Range("B1:B14").Value = Application.Transpose(s1.Range("A" & iRow & ":N" & iRow).Value)
        s2.Range("A1:B22").Copy
        s3.Cells(1, y).PasteSpecial Paste:=xlPasteColumnWidths
        s3.Cells(1, y).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        s3.Cells(1, y).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Columns(Z).ColumnWidth = 0.35
    Z = Z + 3
        y = y + 3
        Application.CutCopyMode = False
        iRow = iRow + 1
    Loop
    a = a + 22
Selection(a).RowHeight = 80.25

End Sub

[Aleksandr H.]

В общих словах как-то так

R = 1
s3.Cells(1, y) => s3.Cells(R, y)
y = y + 3
if y > 10 then
 y = 1:r = r + 23
end if