Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 11.12.2018, 14:10   #1
Kapany3uk
Пользователь
 
Регистрация: 11.12.2018
Сообщений: 20
По умолчанию Заполнение данных в макете этикетки из таблицы

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

Заранее благодарен.
Вложения
Тип файла: xls пример этикетки1.xls (28.5 Кб, 33 просмотров)
Kapany3uk вне форума Ответить с цитированием
Старый 12.12.2018, 17:37   #2
Kapany3uk
Пользователь
 
Регистрация: 11.12.2018
Сообщений: 20
По умолчанию

Добрый день, пока смог разобраться только с заполнением и копированием, подскажите как сделать цикл до последней заполненной Ячейки и как что бы в каждом новом цикле данные брались из следующей ячейки?
Что то я затормозился на этом(
код ниже
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
Kapany3uk вне форума Ответить с цитированием
Старый 12.12.2018, 19:37   #3
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Оформите код "читабельнее"
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 12.12.2018, 20:01   #4
Kapany3uk
Пользователь
 
Регистрация: 11.12.2018
Сообщений: 20
По умолчанию

Сори, ерунда какая-то и в правду отразилась.
Вот читабельная версия:
Код:
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)
Модератор

Последний раз редактировалось Serge_Bliznykov; 12.12.2018 в 22:23.
Kapany3uk вне форума Ответить с цитированием
Старый 12.12.2018, 23:30   #5
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Код:
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
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 13.12.2018, 12:08   #6
Kapany3uk
Пользователь
 
Регистрация: 11.12.2018
Сообщений: 20
По умолчанию

Цитата:
_____
Код программы нужно выделять (форматировать) тегами [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
Теперь не обязательно что бы был третий лист, он создается автоматом

Последний раз редактировалось Kapany3uk; 13.12.2018 в 12:11.
Kapany3uk вне форума Ответить с цитированием
Старый 13.12.2018, 12:42   #7
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Зачем?
Цитата:
Сообщение от Kapany3uk Посмотреть сообщение
Set ra = Range([d5], Range("d" & Rows.Count).End(xlUp))
Цитата:
Сообщение от Kapany3uk Посмотреть сообщение
ActiveSheet.Paste
Вставку рисунка обработали?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 13.12.2018, 13:07   #8
Kapany3uk
Пользователь
 
Регистрация: 11.12.2018
Сообщений: 20
По умолчанию

Согласен, бесполезная команда. Брал из другого массива данных и не проверил.
Это моя первая встреча с макроваси и VBA. Еще очень мало что понимаю в этом. До этого максимум пользовался ВПР ))
Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Зачем?
Цитата:
Сообщение от Kapany3uk
Set ra = Range([d5], Range("d" & Rows.Count).End(xlUp))
Да, теперь копируется вместе с рисунком.
Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Цитата:
Сообщение от Kapany3uk
ActiveSheet.Paste
Вставку рисунка обработали?

Последний раз редактировалось Kapany3uk; 13.12.2018 в 13:11.
Kapany3uk вне форума Ответить с цитированием
Старый 24.12.2018, 12:52   #9
Kapany3uk
Пользователь
 
Регистрация: 11.12.2018
Сообщений: 20
По умолчанию

Всем доброго дня, немного поправил макрос под себя. Теперь появилась следующая задача Нужно что бы создавалось 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
Kapany3uk вне форума Ответить с цитированием
Старый 24.12.2018, 13:30   #10
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

В общих словах как-то так
Код:
R = 1
s3.Cells(1, y) => s3.Cells(R, y)
y = y + 3
if y > 10 then
 y = 1:r = r + 23
end if
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
как верстать по сетке бутстрап если на макете с обох сторон сайт выходит за сетку? nikytt HTML и CSS 1 05.09.2018 09:03
Заполнение таблицы King_Of_Arthur БД в Delphi 0 10.07.2013 07:33
Макрос: заполнение таблицы данными из другой таблицы с автоматическим добавлением строк yevgeniy.demidov Microsoft Office Excel 6 06.09.2012 15:27
поиск данных и заполнение таблицы impact Microsoft Office Excel 5 26.07.2011 16:29
сводная таблица и печпть этикетки yaroslavlevc Microsoft Office Excel 0 03.06.2011 13:22