Страницы: 1
RSS
автоматизация создания этикеток
 
Помогите создать автомат для этикеток.  
Ставишь в верхний левый угол (место для нужной этикетки),  
отвечаешь на Input(номер строки исходной таблицы)  
и радуешься.  
Можно наброском мыслей,если нет времени
 
Вот Вам решение с использованием формул:  
http://excelvba.ru/XL_Files/Sample__31-10-2009__18-34-30.zip  
 
Выделяете диапазон A1:F9, и растягиваете его на нужное количество строк.  
 
Все формулы имеют примерно такой вид:  =ДВССЫЛ("Форма_печать!D"&(СТРОКА()+6)/9*2 + (СТОЛБЕЦ()-2)/3 +3)
 
Большое спасибо,EducatedFool!  
Буду знать как это делается. Попробую перевести это на VBA
 
{quote}{login=Rezh}{date=02.11.2009 09:35}{thema=}{post}Попробую перевести это на VBA{/post}{/quote}  
 
Если бы в данном случае имело смысл использовать макросы для заполнения этикеток - я бы так и сделал. (мне проще написать макрос, чем простейшую формулу)  
 
Но в данном случае формул более чем достаточно...  
Зачем Вам именно макрос?
 
Больше интересует процесс чем результат.  
Меня например поражает логика создания этой формулы на растягивание.  
Сам бы никогда такого придумать не смог  
С другой стороны понимаю,что это приемчик который надо знать  
К VBA примерно отношение такое же.  
С уважением, Rezh.
 
Делать было нечего - написал макрос для создания квитков.  
 
Можно было, конечно, сделать всё проще, но мой вариант относительно универсальный.  
 
Шаблон квитка хранится на скрытом листе ШАБЛОН  
 
Скачать файл с макросом можно здесь:  http://excelvba.ru/XL_Files/Sample__03-11-2009__22-06-31.zip  
 
 
Вот, собственно, весь код:  
 
Sub СоздатьКвиточки()  
   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  
 
   n = 0    ' номер квитка  
   For Each cell In ra.Cells    ' перебираем все заполненные фамилии  
       If Len(cell) > 2 Then    ' если длина фамилии больше, чем 2 символа  
           [Кооператив] = cell.Previous
           [показатель1] = cell.Next: [показатель2] = cell.Next.Next
           [ФИО] = cell: [Сумма] = cell.Offset(, 4)
           ДобавитьКвитокНаЛист Квиточки, n  
           n = n + 1  
       End If  
   Next cell  
   Квиточки.Tab.Color = vbGreen: ActiveSheet.ResetAllPageBreaks: ActiveWindow.View = 2  
   For i = 1 To n ' ставим разрывы страниц  
       If i Mod 6 = 0 Then Set Квиточки.HPageBreaks(i \ 6).Location = Квиточки.Cells(1 + [квиток].Rows.Count * (i \ 2), 1)
   Next  
End Sub  
 
Sub ДобавитьКвитокНаЛист(ByRef sh As Worksheet, n As Long)  
   With [квиток]
       Set МестоДляНовогоКвитка = sh.Cells(1 + .Rows.Count * (n \ 2), 1 + .Columns.Count * (n Mod 2)).Resize(.Rows.Count, .Columns.Count)  
       .Copy МестоДляНовогоКвитка  
       If n < 2 Then    ' устанавливаем ширину столбцов  
           For i = 1 To .Columns.Count  
               МестоДляНовогоКвитка.Cells(i).EntireColumn.ColumnWidth = .Cells(i).EntireColumn.ColumnWidth  
           Next i  
       End If  
       For i = 1 To .Rows.Count    ' устанавливаем высоту строк  
           МестоДляНовогоКвитка.Cells(i, 1).EntireRow.RowHeight = .Cells(i, 1).EntireRow.RowHeight  
       Next i  
   End With  
End Sub
 
Если откинуться от конкретики..  
Создаем образ квиточка, имена полей  
создаем цикл переноса информации из строк исходной таблицы в образ  
оформляем код в событие _Change, т.к. данные динамические,а мы переносим значения    
Не знаю как сделать без _Change?  
Прилично, по отношению к ДВССЫЛ..! да и динамика в ДВССЫЛ.. присутствует    
где бы достать за так Уокенбаха  по формулам в электронном виде.В Рапире у меня почему-то не скачивается  
Могу обменять он же по VBA 2002,  Киммел Access 2002
 
> Не знаю как сделать без _Change?  
 
В предложенном мной макросе никакие Change не используются...  
 
Чем не устраивает мой макрос?
 
так у вас тоже переносятся значения..  
при изменении таблицы обновлять чем?
 
> Прилично, по отношению к ДВССЫЛ..! да и динамика в ДВССЫЛ.. присутствует  
а мой вариант с формулами в таком случае чем не устроил?  
Там та ещё динамика... динамичнее не бывает    
 
> при изменении таблицы обновлять чем?  
Нажатием одной кнопки, запускающей макрос
 
Предложение.  
В квитанциях прописать простые нелетучие форулы типа  
=ИНДЕКС(Форма_печать!$D$5:$D$35;$H$1*6-Х+1)  
где Х - номер квиточка (с 1 по 6 - количество квиточков на странице);  
$H$1 - порядковый номер печатаемого листа.  
бланк только на одной странице.  
Макрос в $H$1 добавляет единицу после каждого напечатаного листа и останавливает печать, если все квиточки напечатаны.
 
Извините, Полный тормоз!Запускать чем то все равно надо.
 
EducatedFool,спасибо за  
Sub ДобавитьКвитокНаЛист(ByRef sh As Worksheet, n As Long)  
Красиво,коротко.
 
Сделал универсальную надстройку для создания и печати этикеток, наклеек, ценников и квитанций из Excel  
 
Скачать её можно здесь: http://excelvba.ru/programmes/Labels  
 
 
PS: Тема эта на форуме, конечно, старая, но мне на сайт отсюда идут люди, и не находят готовое решение (ибо поиск у меня на сайте плохо работает)  
Потому и решил опубликовать ссылку на решение здесь.
 
Бывает же такое! Сам себя узнаю через год :))
 
вот еще один пример
Страницы: 1
Наверх