Блог

Из нашей программы рисования мы получаем лист с данными для распиливания листового материала. Мы хотим сделать наклейку для каждой уникальной пластины.

Идея состоит в том, чтобы переставить данные в формат стикера на новом листе.

например, изображение в формате jpeg.

 Sub Platen_stickers()
Application.ScreenUpdating = False

Dim i As Long
Dim j As Long
Dim xLast As Long
Dim rw As Range
Dim aantalrng As Range
Dim aantal As Range
Dim plaattype As Range
Dim Merk As String, Label As String, Lengte As String, Breedte As String
Dim stickeraantal As Byte, stickergemaakt As Byte
Dim sticker As Range
Dim row As Range
Dim x As Long

On Error Resume Next
xLast = ActiveWorkbook.Sheets(1).Cells(Rows.Count, "B").End(xlUp).row 'searching last filled cell in column B

For i = 8 To xLast Step 1
    If Sheets(1).Cells(i, "B").Value2 = "Code" Then 'searching for header "Code" in column B
        Set plaattype = Sheets(1).Cells(i   1, "B") 'defining the cell below "Code" as range "plaattype"
        Set aantal = plaattype.Offset(0, 2) 'defining cell in row below "Code" and in column D as range "aantal"
        Set aantalrng = Range(aantal, aantal.End(xlDown)) 'defining all numbers in column D under this header as range "aantalrng"

        'inserting new sheet for stickers after current last sheet
    
        ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
        ActiveSheet.Name = plaattype.Value2 'editing sheet name to current type
    
        Set sticker = ActiveSheet.Range(1, 1) 'defining cell A1 of current sheet as current sticker
    
        With ActiveSheet.Range("A1:F31") 'adjusting cell dimensions of range A1:F32 to sticker format (96 sticker per sheet)
            .Columns("A:F").ColumnWidth = 18.14
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        For Each rw In ActiveSheet.Range("A1:F32").Rows
            If rw.row Mod 2 = 0 Then
                rw.RowHeight = 5.25
            Else: rw.RowHeight = 53.25
            End If
        Next rw
        With ActiveSheet.PageSetup 'adjusting print settings to fit stickersheet
            .CenterHorizontally = True
            .CenterVertically = True
            .LeftMargin = Application.CentimetersToPoints(0)
            .RightMargin = Application.CentimetersToPoints(0)
            .TopMargin = Application.CentimetersToPoints(0.6)
            .BottomMargin = Application.CentimetersToPoints(0.6)
            .HeaderMargin = Application.CentimetersToPoints(1.3)
            .FooterMargin = Application.CentimetersToPoints(1.3)
            .Zoom = 87
        End With
    
        x = 1 'setting sticker count on 1
    
        'creating the actual sticker
        For Each row In aantalrng 'running through current data for creating stickers
            stickergemaakt = 0 'resetting counter made sticker in this row
            stickeraantal = aantalrng.Cells(row, 1).Value 'checking how many stickers this row needs making (=value of column D)
            Do Until stickergemaakt > stickeraantal 'looping until made stickers is needed stickers
                Merk = aantalrng.Cells(row, 1).Offset(0, -1).Value 'collecting sticker input
                Label = aantalrng.Cells(row, 1).Offset(0, -3).Value
                Lengte = aantalrng.Cells(row, 1).Offset(0, 1).Value
                Breedte = aantalrng.Cells(row, 1).Offset(0, 2).Value
                sticker.Value = Merk amp; "  " amp; Label amp; vbCrLf amp; Lengte amp; " x " amp; Breedte amp; " mm" amp; vbCrLf amp; plaattype 'writing sticker input in format on current cell on sticker sheet
                If x < 6 Then
                    Set sticker = sticker.Offset(0, 1) 'adjusting to new empty sticker cell => next column
                    x = x   1
                ElseIf x = 6 Then
                    sticker = sticker.Offset(1, -6) 'until reached 6 columns, then next row to start again
                    x = 1
                End If
               stickergemaakt = stickergemaakt   1 'adding counter made sticker with 1
            Loop
            stickeraantal = 0 'resetting number of stickers needed to zero for next row
        Next row
    
    End If
Next

Application.ScreenUpdating = True

End Sub
 

Первая часть, вставка дополнительных листов и настройка размеров наклеек, работает в моем файле с образцами.

Вторая часть, заполнение стикеров данными, я не могу начать.
Я подозреваю, что делаю что-то не так с объявлением диапазона для каждого заголовка. Но что бы я ни настраивал в нем, вторая часть не работает, а иногда и первая часть тоже не работает.