Price tag layout sheet

[NewVeryNew]

Hi Guys,

Two problems I need help with. The first is that I need image 1 to be re-created (on this sheet or another sheet I don't care which one) to look like Image 2. So, image 1 gets it's infomation form other sheets, so basically image 1 could have only two rows of information or it could have 100. Also, the 2nd problem is the height and with of these rows and column. row 1, 5 etc would have a specific height, rows 2, 6, etc would have another specific height, and so on. Columns A to D would have a width of 31.14 (233 pixels). Row 1, 5, etc is left blank as it will be used to place the same image into it.

Any help is appreciated

Image 1

Image 2

 

[NoSparks]

You lost me with this statement

so basically image 1 could have only two rows of information or it could have 100

appears to me that items in image 1 always has 3 rows, can you elaborate on what you mean and how image 2 should be altered to accommodate?

Will the image one sheet always have a specific number of items on row 2 or will it vary?

 

[NewVeryNew]

You lost me with this statement

appears to me that items in image 1 always has 3 rows, can you elaborate on what you mean and how image 2 should be altered to accommodate?

Will the image one sheet always have a specific number of items on row 2 or will it vary?

Sorry about that, it should have read "so basically image 1 could have only two Columns of information or it could have 100". Each column for image 1 will always have 4 rows, with the first one being an image header I plan on putting in later.

 

[NoSparks]

Hopefully this will do what you're after.
You didn't say what the row heights should be so hope the comments in the code will allow you to look after that as need be.

Option Explicit

Sub Price_Tags()
    Dim src As Worksheet    'the source worksheet
    Dim dest As Worksheet   'the destination worksheet
    Dim i As Long, cols As Long
    Dim pasteRow As Long
    
Set src = Sheets("Sheet1")
Set dest = Sheets("Sheet2")

'prevent screen flicker
Application.ScreenUpdating = False

' number of columns to deal with
cols = src.Cells(2, Columns.Count).End(xlToLeft).Column

For i = 1 To cols Step 4
    ' where to paste to
    On Error Resume Next    'in case sheet2 is blank
    pasteRow = dest.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        Select Case pasteRow
            Case 0, 1
                pasteRow = 2
            Case Else
                pasteRow = pasteRow + 2
        End Select
    On Error GoTo 0         're-instate error notification
    
    ' what to copy and where to paste
    With src
        .Cells(2, i).Resize(3, 4).Copy dest.Cells(pasteRow, 1)
    End With
    
    'format destination rows
    With dest.Rows(pasteRow).Cells(1)
        'row heights
        .RowHeight = 30                 'the item number row
        .Offset(-1).RowHeight = 15      'the row above the item number
        .Offset(1).RowHeight = 25       'the price row
        .Offset(2).RowHeight = 20       'the description row
        .Offset(3).RowHeight = 15       'the row below the description
        'item font
        .Resize(, 4).Font.Size = 14
        .Resize(, 4).Font.Bold = True
        'center everything
        .Resize(3, 4).HorizontalAlignment = xlCenter
        .Resize(3, 4).VerticalAlignment = xlCenter
    End With
Next i
        
'format the column widths
With dest
    .Columns("A:D").ColumnWidth = 31.14
End With

Application.ScreenUpdating = True

End Sub

Good luck with the project
NoSparks

 

[NewVeryNew]

Thanks. Works perfect

 

[NoSparks]

Glad I could help and thanks for the feedback